diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 67ad4b43cd..ec16fd5d7b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -34,10 +34,12 @@ setup: - git clone https://github.com/adcroft/MRS.git MRS # Update MOM6-examples and submodules - (cd MOM6-examples && git checkout . && git checkout dev/gfdl && git pull && git submodule init && git submodule update) + - (cd MOM6-examples/src/MOM6 && git submodule update) - test -d MOM6-examples/src/LM3 || make -f MRS/Makefile.clone clone_gfdl -s - make -f MRS/Makefile.clone MOM6-examples/.datasets -s #- (cd MOM6-examples/src/mkmf && git pull https://github.com/adcroft/mkmf.git add_coverage_mode) - env > gitlab_session.log + # Cache everything under tests to unpack for each subsequent stage - cd ../ ; time tar zcf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz tests # Compiles @@ -51,6 +53,30 @@ gnu:repro: - time make -f MRS/Makefile.build MOM6_SRC=../ static_gnu -s -j - time tar zvcf $CACHE_DIR/build-gnu-repro-$CI_PIPELINE_ID.tgz `find build/gnu -name MOM6` +gnu:ocean-only-nolibs: + stage: builds + tags: + - ncrc4 + script: + - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests + - make -f MRS/Makefile.build build/gnu/env && cd build/gnu + # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only + - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{solo_driver,dynamic_symmetric} ../../../src ../../MOM6-examples/src/FMS + - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names + - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + +gnu:ice-ocean-nolibs: + stage: builds + tags: + - ncrc4 + script: + - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests + - make -f MRS/Makefile.build build/gnu/env && cd build/gnu + # mkdir -p build/gnu/repro/symmetric_dynamic/ocean_only && cd build/gnu/repro/symmetric_dynamic/ocean_only + - ../../MOM6-examples/src/mkmf/bin/list_paths -l ../../../config_src/{coupled_driver,dynamic} ../../../src ../../MOM6-examples/src/{FMS,coupler,SIS2,icebergs,ice_ocean_extras,land_null,atmos_null} + - ../../MOM6-examples/src/mkmf/bin/mkmf -t ../../MOM6-examples/src/mkmf/templates/ncrc-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names + - time (source ./env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + intel:repro: stage: builds tags: @@ -90,8 +116,9 @@ run: - time tar zxf $CACHE_DIR/build-pgi-repro-$CI_PIPELINE_ID.tgz # time tar zxf $CACHE_DIR/build-gnu-debug-$CI_PIPELINE_ID.tgz - echo "make -f MRS/Makefile.tests all -B" > job.sh - - msub -l partition=c4,nodes=29,walltime=00:24:00,qos=norm -q debug -S /bin/tcsh -j oe -A gfdl_o -z -o log.$CI_PIPELINE_ID -N mom6_regression -K job.sh + - msub -l partition=c4,nodes=29,walltime=00:31:00,qos=norm -q debug -S /bin/tcsh -j oe -A gfdl_o -z -o log.$CI_PIPELINE_ID -N mom6_regression -K job.sh - cat log.$CI_PIPELINE_ID + - test -f restart_results_gnu.tar.gz - time tar zvcf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz *.tar.gz # Tests @@ -194,6 +221,16 @@ gnu:restart: - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz - make -f MRS/Makefile.tests gnu_check_restarts +gnu:params: + stage: tests + tags: + - ncrc4 + script: + - time tar zxf $CACHE_DIR/tests_$CI_PIPELINE_ID.tgz && cd tests + - time tar zxf $CACHE_DIR/results-$CI_PIPELINE_ID.tgz + - make -f MRS/Makefile.tests params_gnu_symmetric + allow_failure: true + cleanup: stage: cleanup tags: diff --git a/.gitmodules b/.gitmodules index 637f1188ed..b499e43096 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,9 @@ [submodule "pkg/GSW-Fortran"] path = pkg/GSW-Fortran url = https://github.com/TEOS-10/GSW-Fortran.git +[submodule "pkg/MOM6_DA_hooks"] + path = pkg/MOM6_DA_hooks + url = https://github.com/MJHarrison-GFDL/MOM6_DA_hooks.git +[submodule "pkg/geoKdTree"] + path = pkg/geoKdTree + url = https://github.com/travissluka/geoKdTree.git diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index 6b0fedc336..7d6ccd84cf 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -14,9 +14,10 @@ module MOM_surface_forcing 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 use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing, copy_common_forcing_fields +use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing @@ -44,7 +45,7 @@ module MOM_surface_forcing #include -public convert_IOB_to_fluxes +public convert_IOB_to_fluxes, convert_IOB_to_forces public surface_forcing_init public ice_ocn_bnd_type_chksum public forcing_save_restart @@ -128,13 +129,15 @@ module MOM_surface_forcing character(len=30) :: salt_restore_var_name ! name of surface salinity in salt_restore_file logical :: mask_srestore ! if true, apply a 2-dimensional mask to the surface ! salinity restoring fluxes. The masking file should be - ! in inputdir/salt_restore_mask.nc and the field should be name 'mask' + ! in inputdir/salt_restore_mask.nc and the field should + ! be named 'mask' real, pointer, dimension(:,:) :: srestore_mask => NULL() ! mask for SSS restoring character(len=200) :: temp_restore_file ! filename for sst restoring data character(len=30) :: temp_restore_var_name ! name of surface temperature in temp_restore_file logical :: mask_trestore ! if true, apply a 2-dimensional mask to the surface ! temperature restoring fluxes. The masking file should be - ! in inputdir/temp_restore_mask.nc and the field should be name 'mask' + ! in inputdir/temp_restore_mask.nc and the field should + ! be named 'mask' real, pointer, dimension(:,:) :: trestore_mask => NULL() ! mask for SST restoring integer :: id_srestore = -1 ! id number for time_interp_external. integer :: id_trestore = -1 ! id number for time_interp_external. @@ -152,49 +155,54 @@ module MOM_surface_forcing ! the elements, units, and conventions that exactly conform to the use for ! MOM-based coupled models. type, public :: ice_ocean_boundary_type - real, pointer, dimension(:,:) :: u_flux =>NULL() ! i-direction wind stress (Pa) - real, pointer, dimension(:,:) :: v_flux =>NULL() ! j-direction wind stress (Pa) - real, pointer, dimension(:,:) :: t_flux =>NULL() ! sensible heat flux (W/m2) - real, pointer, dimension(:,:) :: q_flux =>NULL() ! specific humidity flux (kg/m2/s) - real, pointer, dimension(:,:) :: salt_flux =>NULL() ! salt flux (kg/m2/s) - real, pointer, dimension(:,:) :: lw_flux =>NULL() ! long wave radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() ! direct visible sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() ! diffuse visible sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() ! direct Near InfraRed sw radiation (W/m2) - real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() ! diffuse Near InfraRed sw radiation (W/m2) - real, pointer, dimension(:,:) :: lprec =>NULL() ! mass flux of liquid precip (kg/m2/s) - real, pointer, dimension(:,:) :: fprec =>NULL() ! mass flux of frozen precip (kg/m2/s) - real, pointer, dimension(:,:) :: runoff =>NULL() ! mass flux of liquid runoff (kg/m2/s) - real, pointer, dimension(:,:) :: calving =>NULL() ! mass flux of frozen runoff (kg/m2/s) - real, pointer, dimension(:,:) :: ustar_berg =>NULL() ! frictional velocity beneath icebergs (m/s) - real, pointer, dimension(:,:) :: area_berg =>NULL() ! area covered by icebergs(m2/m2) - real, pointer, dimension(:,:) :: mass_berg =>NULL() ! mass of icebergs(kg/m2) - real, pointer, dimension(:,:) :: runoff_hflx =>NULL() ! heat content of liquid runoff (W/m2) - real, pointer, dimension(:,:) :: calving_hflx =>NULL() ! heat content of frozen runoff (W/m2) - real, pointer, dimension(:,:) :: p =>NULL() ! pressure of overlying ice and atmosphere - ! on ocean surface (Pa) - real, pointer, dimension(:,:) :: mi =>NULL() ! mass of ice (kg/m2) - integer :: xtype ! REGRID, REDIST or DIRECT - type(coupler_2d_bc_type) :: fluxes ! A structure that may contain an - ! array of named fields used for - ! passive tracer fluxes. - integer :: wind_stagger = -999 ! A flag indicating the spatial discretization of - ! wind stresses. This flag may be set by the - ! flux-exchange code, based on what the sea-ice - ! model is providing. Otherwise, the value from - ! the surface_forcing_CS is used. + real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress (Pa) + real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress (Pa) + real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux (W/m2) + real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux (kg/m2/s) + real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux (kg/m2/s) + real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() !< direct Near InfraRed sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation (W/m2) + real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip (kg/m2/s) + real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip (kg/m2/s) + real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff (kg/m2/s) + real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff (kg/m2/s) + real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs (m/s) + real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs(m2/m2) + real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) + real, pointer, dimension(:,:) :: runoff_hflx =>NULL() !< heat content of liquid runoff (W/m2) + real, pointer, dimension(:,:) :: calving_hflx =>NULL() !< heat content of frozen runoff (W/m2) + real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere + !< on ocean surface (Pa) + real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice (kg/m2) + real, pointer, dimension(:,:) :: ice_rigidity =>NULL() !< rigidity of the sea ice, sea-ice and + !! ice-shelves, expressed as a coefficient + !! for divergence damping, as determined + !! outside of the ocean model in (m3/s) + integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT + type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of + !! named fields used for passive tracer fluxes. + integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of + !! wind stresses. This flag may be set by the + !! flux-exchange code, based on what the sea-ice + !! model is providing. Otherwise, the value from + !! the surface_forcing_CS is used. end type ice_ocean_boundary_type integer :: id_clock_forcing contains -subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, & +!> This subroutine translates the Ice_ocean_boundary_type into a MOM +!! thermodynamic forcing type, including changes of units, sign conventions, +!! and putting the fields into arrays with MOM-standard halos. +subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & sfc_state, restore_salt, restore_temp) type(ice_ocean_boundary_type), & target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive !! the ocean in a coupled model - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< A structure containing pointers to !! all possible mass, heat or salt flux forcing fields. !! Unused fields have NULL ptrs. @@ -206,34 +214,11 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, !! previous call to surface_forcing_init. type(surface), intent(in) :: sfc_state !< A structure containing fields that describe the !! surface state of the ocean. - logical, optional, intent(in) :: restore_salt, restore_temp - -! This subroutine translates the Ice_ocean_boundary_type into a -! MOM forcing type, including changes of units, sign conventions, -! and puting the fields into arrays with MOM-standard halos. - -! Arguments: -! IOB ice-ocean boundary type w/ fluxes to drive ocean in a coupled model -! (out) fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (in) index_bounds - the i- and j- size of the arrays in IOB. -! (in) Time - The time of the fluxes, used for interpolating the salinity -! to the right time, when it is being restored. -! (in) G - The ocean's grid structure. -! (in) CS - A pointer to the control structure returned by a previous -! call to surface_forcing_init. -! (in) state - A structure containing fields that describe the -! surface state of the ocean. -! (in) restore_salt - if true, salinity is restored to a target value. -! (in) restore_temp - if true, temperature is restored to a target value. + logical, optional, intent(in) :: restore_salt !< If true, salinity is restored to a target value. + logical, optional, intent(in) :: restore_temp !< If true, temperature is restored to a target value. - real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & ! Zonal wind stresses at q points (Pa) - tauy_at_q ! Meridional wind stresses at q points (Pa) real, dimension(SZI_(G),SZJ_(G)) :: & - taux_at_h, & ! Zonal wind stresses at h points (Pa) - tauy_at_h, & ! Meridional wind stresses at h points (Pa) data_restore, & ! The surface value toward which to restore (g/kg or degC) SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value (deg C) SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value (g/kg) @@ -247,16 +232,6 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, ! sum, used with units of m2 or (kg/s) open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria - real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) - real :: Irho0 ! inverse of the mean density in (m^3/kg) - real :: taux2, tauy2 ! squared wind stresses (Pa^2) - real :: tau_mag ! magnitude of the wind stress (Pa) - real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) - real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) - real :: mass_ice ! mass of sea ice at a face (kg/m^2) - real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) - - integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) 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 :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd @@ -282,7 +257,6 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 C_p = fluxes%C_p - Irho0 = 1.0/CS%Rho0 open_ocn_mask(:,:) = 1.0 pme_adj(:,:) = 0.0 fluxes%vPrecGlobalAdj = 0.0 @@ -302,8 +276,6 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & ustar=.true., press=.true.) - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -312,6 +284,11 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, 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 + else + fluxes%p_surf_SSH => fluxes%p_surf_full + endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) @@ -328,21 +305,19 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, 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 - - call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) - call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) - - if (CS%rigid_sea_ice) then - call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) - call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) - endif + enddo ; enddo if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) fluxes%dt_buoy_accum = 0.0 endif ! endif for allocation and initialization + + if (((associated(IOB%ustar_berg) .and. (.not.associated(fluxes%ustar_berg))) & + .or. (associated(IOB%area_berg) .and. (.not.associated(fluxes%area_berg)))) & + .or. (associated(IOB%mass_berg) .and. (.not.associated(fluxes%mass_berg)))) & + call allocate_forcing_type(G, fluxes, iceberg=.true.) + if ((.not.coupler_type_initialized(fluxes%tr_fluxes)) .and. & coupler_type_initialized(IOB%fluxes)) & call coupler_type_spawn(IOB%fluxes, fluxes%tr_fluxes, & @@ -353,8 +328,8 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 + fluxes%heat_added(:,:)=0.0 + fluxes%salt_flux_added(:,:)=0.0 endif ! allocation and initialization on first call to this routine @@ -377,8 +352,8 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, open_ocn_mask(:,:) = 1.0 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) .le. -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo + if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie @@ -386,7 +361,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, 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 ! 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) @@ -407,7 +382,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, (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) @@ -417,7 +392,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, 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) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo endif endif endif @@ -427,22 +402,11 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, if (restore_sst) then call time_interp_external(CS%id_trestore,Time,data_restore) do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- sfc_state%SST(i,j) - 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 - endif - - wind_stagger = CS%wind_stagger - if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & - (IOB%wind_stagger == CGRID_NE)) wind_stagger = IOB%wind_stagger - if (wind_stagger == BGRID_NE) then - ! This is necessary to fill in the halo points. - taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 - endif - if (wind_stagger == AGRID) then - ! This is necessary to fill in the halo points. - taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 + delta_sst = data_restore(i,j)- sfc_state%SST(i,j) + 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 endif @@ -450,89 +414,89 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, i0 = is - isc_bnd ; j0 = js - jsc_bnd do j=js,je ; do i=is,ie - if (wind_stagger == BGRID_NE) then - if (ASSOCIATED(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (ASSOCIATED(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - elseif (wind_stagger == AGRID) then - if (ASSOCIATED(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (ASSOCIATED(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - else ! C-grid wind stresses. - if (ASSOCIATED(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier - if (ASSOCIATED(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier - endif - - if (ASSOCIATED(IOB%lprec)) & + if (associated(IOB%lprec)) & fluxes%lprec(i,j) = IOB%lprec(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%fprec)) & + if (associated(IOB%fprec)) & fluxes%fprec(i,j) = IOB%fprec(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%q_flux)) & + if (associated(IOB%q_flux)) & fluxes%evap(i,j) = - IOB%q_flux(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%runoff)) & + if (associated(IOB%runoff)) & fluxes%lrunoff(i,j) = IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%calving)) & + if (associated(IOB%calving)) & fluxes%frunoff(i,j) = IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) - if (((ASSOCIATED(IOB%ustar_berg) .and. (.not. ASSOCIATED(fluxes%ustar_berg))) & - .or. (ASSOCIATED(IOB%area_berg) .and. (.not. ASSOCIATED(fluxes%area_berg)))) & - .or. (ASSOCIATED(IOB%mass_berg) .and. (.not. ASSOCIATED(fluxes%mass_berg)))) & - call allocate_forcing_type(G, fluxes, iceberg=.true.) - - if (ASSOCIATED(IOB%ustar_berg)) & + if (associated(IOB%ustar_berg)) & fluxes%ustar_berg(i,j) = IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%area_berg)) & + if (associated(IOB%area_berg)) & fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%mass_berg)) & + if (associated(IOB%mass_berg)) & fluxes%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%runoff_hflx)) & + if (associated(IOB%runoff_hflx)) & fluxes%heat_content_lrunoff(i,j) = IOB%runoff_hflx(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%calving_hflx)) & + if (associated(IOB%calving_hflx)) & fluxes%heat_content_frunoff(i,j) = IOB%calving_hflx(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%lw_flux)) & + if (associated(IOB%lw_flux)) & fluxes%LW(i,j) = IOB%lw_flux(i-i0,j-j0) * G%mask2dT(i,j) - if (ASSOCIATED(IOB%t_flux)) & + if (associated(IOB%t_flux)) & fluxes%sens(i,j) = - IOB%t_flux(i-i0,j-j0) * G%mask2dT(i,j) fluxes%latent(i,j) = 0.0 - if (ASSOCIATED(IOB%fprec)) then + if (associated(IOB%fprec)) then fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion fluxes%latent_fprec_diag(i,j) = -G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*CS%latent_heat_fusion endif - if (ASSOCIATED(IOB%calving)) then + if (associated(IOB%calving)) then fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion fluxes%latent_frunoff_diag(i,j) = -G%mask2dT(i,j) * IOB%calving(i-i0,j-j0)*CS%latent_heat_fusion endif - if (ASSOCIATED(IOB%q_flux)) then + if (associated(IOB%q_flux)) then fluxes%latent(i,j) = fluxes%latent(i,j) - IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor fluxes%latent_evap_diag(i,j) = -G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) - if (ASSOCIATED(IOB%sw_flux_vis_dir)) & + if (associated(IOB%sw_flux_vis_dir)) & fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dir(i-i0,j-j0) - if (ASSOCIATED(IOB%sw_flux_vis_dif)) & + if (associated(IOB%sw_flux_vis_dif)) & fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dif(i-i0,j-j0) - if (ASSOCIATED(IOB%sw_flux_nir_dir)) & + if (associated(IOB%sw_flux_nir_dir)) & fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dir(i-i0,j-j0) - if (ASSOCIATED(IOB%sw_flux_nir_dif)) & + if (associated(IOB%sw_flux_nir_dif)) & fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dif(i-i0,j-j0) 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 + ! 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) * 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) * 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 + ! more salt restoring logic - if (ASSOCIATED(IOB%salt_flux)) then + if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) - IOB%salt_flux(i-i0,j-j0)) fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*( -IOB%salt_flux(i-i0,j-j0) ) @@ -563,7 +527,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, ! Bob thinks this is trying ensure the net fresh-water of the ocean + sea-ice system ! is constant. ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA - if (ASSOCIATED(IOB%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & + if (associated(IOB%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & net_FW(i,j) = net_FW(i,j) + sign_for_net_FW_bug * G%areaT(i,j) * & (IOB%salt_flux(i-i0,j-j0) / CS%ice_salt_concentration) net_FW2(i,j) = net_FW(i,j) / G%areaT(i,j) @@ -573,18 +537,121 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, 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) + (net_FW2(i,j) - net_FW(i,j)/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) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo + endif + + endif + + if (coupler_type_initialized(fluxes%tr_fluxes) .and. & + coupler_type_initialized(IOB%fluxes)) & + call coupler_type_copy_data(IOB%fluxes, fluxes%tr_fluxes) + + if (CS%allow_flux_adjustments) then + ! Apply adjustments to fluxes + call apply_flux_adjustments(G, CS, Time, fluxes) + endif + + ! Allow for user-written code to alter fluxes after all the above + call user_alter_forcing(sfc_state, fluxes, Time, G, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) + +end subroutine convert_IOB_to_fluxes + +!> This subroutine translates the Ice_ocean_boundary_type into a MOM +!! mechanical forcing type, including changes of units, sign conventions, +!! and putting the fields into arrays with MOM-standard halos. +subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + + + real, dimension(SZIB_(G),SZJB_(G)) :: & + taux_at_q, & ! Zonal wind stresses at q points (Pa) + tauy_at_q ! Meridional wind stresses at q points (Pa) + + real, dimension(SZI_(G),SZJ_(G)) :: & + rigidity_at_h, & ! Ice rigidity at tracer points (m3 s-1) + taux_at_h, & ! Zonal wind stresses at h points (Pa) + tauy_at_h ! Meridional wind stresses at h points (Pa) + + real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) + real :: Irho0 ! inverse of the mean density in (m^3/kg) + real :: taux2, tauy2 ! squared wind stresses (Pa^2) + real :: tau_mag ! magnitude of the wind stress (Pa) + real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) + real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) + real :: mass_ice ! mass of sea ice at a face (kg/m^2) + real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) + + integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) + 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 :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + call cpu_clock_begin(id_clock_forcing) + + isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) + jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) + 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 + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + i0 = is - isc_bnd ; j0 = js - jsc_bnd + + Irho0 = 1.0/CS%Rho0 + + ! allocation and initialization if this is the first time that this + ! mechanical forcing type has been used. + if (.not.forces%initialized) then + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & + press=.true.) + + call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) + call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) + if (CS%use_limited_P_SSH) then + forces%p_surf_SSH => forces%p_surf + else + forces%p_surf_SSH => forces%p_surf_full + endif + + if (CS%rigid_sea_ice) then + call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) + call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) endif + forces%initialized = .true. endif + if ( (associated(IOB%area_berg) .and. (.not. associated(forces%area_berg))) .or. & + (associated(IOB%mass_berg) .and. (.not. associated(forces%mass_berg))) ) & + call allocate_mech_forcing(G, forces, iceberg=.true.) + if (associated(IOB%ice_rigidity)) then + rigidity_at_h(:,:) = 0.0 + call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) + call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) + endif + + forces%accumulate_rigidity = .true. ! Multiple components may contribute to rigidity. + if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 + if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 + ! applied surface pressure from atmosphere and cryosphere - if (ASSOCIATED(IOB%p)) then + if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then do j=js,je ; do i=is,ie forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) @@ -596,18 +663,55 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, forces%p_surf(i,j) = forces%p_surf_full(i,j) enddo ; enddo endif - if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf - else - forces%p_surf_SSH => forces%p_surf_full - endif + else + do j=js,je ; do i=is,ie + forces%p_surf_full(i,j) = 0.0 + forces%p_surf(i,j) = 0.0 + enddo ; enddo + endif + forces%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + + wind_stagger = CS%wind_stagger + if ((IOB%wind_stagger == AGRID) .or. (IOB%wind_stagger == BGRID_NE) .or. & + (IOB%wind_stagger == CGRID_NE)) wind_stagger = IOB%wind_stagger + if (wind_stagger == BGRID_NE) then + ! This is necessary to fill in the halo points. + taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 endif + if (wind_stagger == AGRID) then + ! This is necessary to fill in the halo points. + taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 + endif + + ! obtain fluxes from IOB; note the staggering of indices + do j=js,je ; do i=is,ie + if (associated(IOB%area_berg)) & + forces%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%mass_berg)) & + forces%mass_berg(i,j) = IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%ice_rigidity)) & + rigidity_at_h(i,j) = IOB%ice_rigidity(i-i0,j-j0) * G%mask2dT(i,j) + + if (wind_stagger == BGRID_NE) then + if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + elseif (wind_stagger == AGRID) then + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + else ! C-grid wind stresses. + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + endif + + enddo ; enddo ! surface momentum stress related fields as function of staggering if (wind_stagger == BGRID_NE) then if (G%symmetric) & call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) + call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE, halo=1) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 @@ -644,7 +748,8 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, enddo ; enddo elseif (wind_stagger == AGRID) then - call pass_vector(taux_at_h, tauy_at_h, G%Domain,stagger=AGRID) + 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 @@ -672,7 +777,7 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, else ! C-grid wind stresses. if (G%symmetric) & call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) - call pass_vector(forces%taux, forces%tauy, G%Domain) + call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) do j=js,je ; do i=is,ie taux2 = 0.0 @@ -694,72 +799,71 @@ subroutine convert_IOB_to_fluxes(IOB, forces, fluxes, index_bounds, Time, G, CS, endif ! endif for wind related fields + ! sea ice related dynamic fields + if (associated(IOB%ice_rigidity)) then + call pass_var(rigidity_at_h, G%Domain, halo=1) + do I=is-1,ie ; do j=js,je + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & + min(rigidity_at_h(i,j), rigidity_at_h(i+1,j)) + enddo ; enddo + do i=is,ie ; do J=js-1,je + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + & + min(rigidity_at_h(i,j), rigidity_at_h(i,j+1)) + enddo ; enddo + endif - ! sea ice related fields if (CS%rigid_sea_ice) then - ! The commented out code here and in the following lines is the correct - ! version, but the incorrect version is being retained temporarily to avoid - ! changing answers. - call pass_var(forces%p_surf_full, G%Domain) + call pass_var(forces%p_surf_full, G%Domain, halo=1) I_GEarth = 1.0 / G%G_Earth Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) - do I=isd,ied-1 ; do j=jsd,jed + do I=is-1,ie ; do j=js,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & (mass_ice + CS%rigid_sea_ice_mass) endif - ! CAUTION: with both rigid_sea_ice and ice shelves, we will need to make this - ! a maximum for the second call. - forces%rigidity_ice_u(I,j) = Kv_rho_ice * mass_eff + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff enddo ; enddo - do i=isd,ied ; do J=jsd,jed-1 + do i=is,ie ; do J=js-1,je mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth mass_eff = 0.0 if (mass_ice > CS%rigid_sea_ice_mass) then mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & (mass_ice + CS%rigid_sea_ice_mass) endif - forces%rigidity_ice_v(i,J) = Kv_rho_ice * mass_eff + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff enddo ; enddo endif - if (coupler_type_initialized(fluxes%tr_fluxes) .and. & - coupler_type_initialized(IOB%fluxes)) & - call coupler_type_copy_data(IOB%fluxes, fluxes%tr_fluxes) - if (CS%allow_flux_adjustments) then - ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, forces, fluxes) + ! Apply adjustments to forces + call apply_force_adjustments(G, CS, Time, forces) endif - ! Allow for user-written code to alter fluxes after all the above - call user_alter_forcing(sfc_state, fluxes, Time, G, CS%urf_CS) +!### ! Allow for user-written code to alter fluxes after all the above +!### call user_alter_mech_forcing(forces, Time, G, CS%urf_CS) call cpu_clock_end(id_clock_forcing) -end subroutine convert_IOB_to_fluxes +end subroutine convert_IOB_to_forces -!> Adds flux adjustments obtained via data_override +!> Adds thermodynamic flux adjustments obtained via data_override !! Component name is 'OCN' !! Available adjustments are: -!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) -!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) +!! - hflx_adj (Heat flux into the ocean, in W m-2) +!! - sflx_adj (Salt flux into the ocean, in kg salt m-2 s-1) +!! - prcme_adj (Fresh water flux into the ocean, in kg m-2 s-1) +subroutine apply_flux_adjustments(G, CS, Time, fluxes) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure type(time_type), intent(in) :: Time !< Model time structure - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< Surface fluxes structure ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Fluxes at h points (W m-2 or kg m-2 s-1) integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau - logical :: overrode_x, overrode_y, overrode_h + logical :: overrode_h isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec @@ -769,7 +873,7 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif - if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) + ! Not needed? ! if (overrode_h) call pass_var(fluxes%heat_added, G%Domain) overrode_h = .false. call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) @@ -777,7 +881,7 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif - if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) + ! Not needed? ! if (overrode_h) call pass_var(fluxes%salt_flux_added, G%Domain) overrode_h = .false. call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) @@ -785,7 +889,29 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) if (overrode_h) then ; do j=jsc,jec ; do i=isc,iec fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) enddo ; enddo ; endif - if (overrode_h) call pass_var(fluxes%vprec, G%Domain) + ! Not needed? ! if (overrode_h) call pass_var(fluxes%vprec, G%Domain) +end subroutine apply_flux_adjustments + +!> Adds mechanical forcing adjustments obtained via data_override +!! Component name is 'OCN' +!! Available adjustments are: +!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) +!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) +subroutine apply_force_adjustments(G, CS, Time, forces) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure + type(time_type), intent(in) :: Time !< Model time structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) + + integer :: isc, iec, jsc, jec, i, j + real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + logical :: overrode_x, overrode_y + + isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 ! Either reads data or leaves contents unchanged @@ -798,7 +924,7 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) "Both taux_adj and tauy_adj must be specified, or neither, in data_table") ! Rotate winds - call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID) + call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID, halo=1) do j=jsc-1,jec+1 ; do i=isc-1,iec+1 dLonDx = G%geoLonCu(I,j) - G%geoLonCu(I-1,j) dLonDy = G%geoLonCv(i,J) - G%geoLonCv(i,J-1) @@ -822,7 +948,7 @@ subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) enddo ; enddo endif ! overrode_x .or. overrode_y -end subroutine apply_flux_adjustments +end subroutine apply_force_adjustments subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) @@ -891,7 +1017,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res CS%diag => diag - call write_version_number (version) + call write_version_number(version) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1228,12 +1354,12 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) write(outunit,100) 'iobt%runoff ', mpp_chksum( iobt%runoff ) write(outunit,100) 'iobt%calving ', mpp_chksum( iobt%calving ) write(outunit,100) 'iobt%p ', mpp_chksum( iobt%p ) - if (ASSOCIATED(iobt%ustar_berg)) & - write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) - if (ASSOCIATED(iobt%area_berg)) & - write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) - if (ASSOCIATED(iobt%mass_berg)) & - write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) + if (associated(iobt%ustar_berg)) & + write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) + if (associated(iobt%area_berg)) & + write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) + if (associated(iobt%mass_berg)) & + write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index e918f642d1..cd72884392 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -24,10 +24,12 @@ module ocean_model_mod use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end -use MOM_domains, only : pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +use MOM_forcing_type, only : allocate_forcing_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing @@ -36,10 +38,11 @@ module ocean_model_mod use MOM_get_input, only : Get_MOM_Input, directories use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_surface_forcing, only : surface_forcing_init, convert_IOB_to_fluxes -use MOM_surface_forcing, only : ice_ocn_bnd_type_chksum +use MOM_surface_forcing, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum use MOM_surface_forcing, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing, only : forcing_save_restart use MOM_time_manager, only : time_type, get_time, set_time, operator(>) @@ -51,7 +54,7 @@ module ocean_model_mod use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only : ice_shelf_end, ice_shelf_save_restart +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data @@ -59,11 +62,11 @@ module ocean_model_mod use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux -use MOM_forcing_type, only : allocate_forcing_type use fms_mod, only : stdout use mpp_mod, only : mpp_chksum -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves #include @@ -139,26 +142,20 @@ module ocean_model_mod type, public :: ocean_state_type ; private ! This type is private, and can therefore vary between different ocean models. logical :: is_ocean_PE = .false. !< True if this is an ocean PE. - type(time_type) :: Time !< The ocean model's time and master clock. - integer :: Restart_control !< An integer that is bit-tested to determine whether - !! incremental restart files are saved and whether they - !! have a time stamped name. +1 (bit 0) for generic - !! files and +2 (bit 1) for time-stamped files. A - !! restart file is saved at the end of a run segment - !! unless Restart_control is negative. + type(time_type) :: Time !< The ocean model's time and master clock. + integer :: Restart_control !< An integer that is bit-tested to determine whether + !! incremental restart files are saved and whether they + !! have a time stamped name. +1 (bit 0) for generic + !! files and +2 (bit 1) for time-stamped files. A + !! restart file is saved at the end of a run segment + !! unless Restart_control is negative. integer :: nstep = 0 !< The number of calls to update_ocean. logical :: use_ice_shelf !< If true, the ice shelf model is enabled. + logical :: use_waves !< If true use wave coupling. - ! Many of the following variables do not appear to belong here. -RWH - logical :: icebergs_apply_rigid_boundary ! If true, the icebergs can change ocean bd condition. - real :: kv_iceberg ! The viscosity of the icebergs in m2/s (for ice rigidity) - real :: berg_area_threshold ! Fraction of grid cell which iceberg must occupy - !so that fluxes below are set to zero. (0.5 is a - !good value to use. Not applied for negative values. - real :: latent_heat_fusion ! Latent heat of fusion - real :: density_iceberg ! A typical density of icebergs in kg/m3 (for ice rigidity) - + logical :: icebergs_alter_ocean !< If true, the icebergs can change ocean the + !! ocean dynamics and forcing fluxes. logical :: restore_salinity !< If true, the coupled MOM driver adds a term to !! restore salinity to a specified value. logical :: restore_temp !< If true, the coupled MOM driver adds a term to @@ -207,6 +204,11 @@ module ocean_model_mod Ice_shelf_CSp => NULL() !< A pointer to the control structure for the !! ice shelf model that couples with MOM6. This !! is null if there is no ice shelf. + type(marine_ice_CS), pointer :: & + marine_ice_CSp => NULL() !< A pointer to the control structure for the + !! marine ice effects module. + type(wave_parameters_cs), pointer :: & + Waves !< A structure containing pointers to the surface wave fields type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure type(MOM_restart_CS), pointer :: & @@ -352,22 +354,9 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & "If true, enables the ice shelf model.", default=.false.) - call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_apply_rigid_boundary, & + call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_alter_ocean, & "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) - if (OS%icebergs_apply_rigid_boundary) then - call get_param(param_file, mdl, "KV_ICEBERG", OS%kv_iceberg, & - "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) - call get_param(param_file, mdl, "DENSITY_ICEBERGS", OS%density_iceberg, & - "A typical density of icebergs.", units="kg m-3", default=917.0) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", OS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) - call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", OS%berg_area_threshold, & - "Fraction of grid cell which iceberg must occupy, so that fluxes \n"//& - "below berg are set to zero. Not applied for negative \n"//& - " values.", units="non-dim", default=-1.0) - endif - OS%press_to_z = 1.0/(Rho0*G_Earth) ! Consider using a run-time flag to determine whether to do the diagnostic @@ -382,14 +371,21 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn) call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & OS%diag, OS%forces, OS%fluxes) endif - if (OS%icebergs_apply_rigid_boundary) then - !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true + if (OS%icebergs_alter_ocean) then + call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) if (.not. OS%use_ice_shelf) & call allocate_forcing_type(OS%grid, OS%fluxes, shelf=.true.) endif - if (ASSOCIATED(OS%grid%Domain%maskmap)) then + call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & + "If true, enables surface wave modules.", default=.false.) + if (OS%use_waves) then + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, param_file, OS%Waves, OS%diag) + else + call MOM_wave_interface_init_lite(param_file) + endif + + if (associated(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & OS%diag, maskmap=OS%grid%Domain%maskmap, & gas_fields_ocn=gas_fields_ocn) @@ -436,38 +432,30 @@ end subroutine ocean_model_init !! returning the publicly visible ocean surface properties in Ocean_sfc and !! storing the new ocean properties in Ocean_state. subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & - time_start_update, Ocean_coupling_time_step) + time_start_update, Ocean_coupling_time_step, & + update_dyn, update_thermo, Ocn_fluxes_used) type(ice_ocean_boundary_type), & - intent(in) :: Ice_ocean_boundary !< A structure containing the - !! various forcing fields coming from the ice. - type(ocean_state_type), pointer :: OS !< A pointer to a private structure containing - !! the internal ocean state. - type(ocean_public_type), intent(inout) :: Ocean_sfc !< A structure containing all the - !! publicly visible ocean surface fields after - !! a coupling time step. The data in this type is - !! intent out. - type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. - type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over - !! which to advance the ocean. -! This subroutine uses the forcing in Ice_ocean_boundary to advance the -! ocean model's state from the input value of Ocean_state (which must be for -! time time_start_update) for a time interval of Ocean_coupling_time_step, -! returning the publicly visible ocean surface properties in Ocean_sfc and -! storing the new ocean properties in Ocean_state. - -! Arguments: Ice_ocean_boundary - A structure containing the various forcing -! fields coming from the ice. It is intent in. -! (inout) Ocean_state - A structure containing the internal ocean state. -! (out) Ocean_sfc - A structure containing all the publicly visible ocean -! surface fields after a coupling time step. -! (in) time_start_update - The time at the beginning of the update step. -! (in) Ocean_coupling_time_step - The amount of time over which to advance -! the ocean. - -! Note: although several types are declared intent(inout), this is to allow for -! the possibility of halo updates and to keep previously allocated memory. -! In practice, Ice_ocean_boundary is intent in, Ocean_state is private to -! this module and intent inout, and Ocean_sfc is intent out. + intent(in) :: Ice_ocean_boundary !< A structure containing the + !! various forcing fields coming from the ice. + type(ocean_state_type), & + pointer :: OS !< A pointer to a private structure containing + !! the internal ocean state. + type(ocean_public_type), & + intent(inout) :: Ocean_sfc !< A structure containing all the + !! publicly visible ocean surface fields after + !! a coupling time step. The data in this type is + !! intent out. + type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. + type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over + !! which to advance the ocean. + logical, optional, intent(in) :: update_dyn !< If present and false, do not do updates + !! due to the ocean dynamics. + logical, optional, intent(in) :: update_thermo !< If present and false, do not do updates + !! due to the ocean thermodynamics or remapping. + logical, optional, intent(in) :: Ocn_fluxes_used !< If present, this indicates whether the + !! cumulative thermodynamic fluxes from the ocean, + !! like frazil, have been used and should be reset. + type(time_type) :: Master_time ! This allows step_MOM to temporarily change ! the time that is seen by internal modules. type(time_type) :: Time1 ! The value of the ocean model's time at the @@ -486,6 +474,8 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & type(time_type) :: Time2 ! A temporary time. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans ! multiple dynamic timesteps. + logical :: do_dyn ! If true, step the ocean dynamics and transport. + logical :: do_thermo ! If true, step the ocean thermodynamics. logical :: step_thermo ! If true, take a thermodynamic step. integer :: secs, days integer :: is, ie, js, je @@ -505,6 +495,9 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & return endif + do_dyn = .true. ; if (present(update_dyn)) do_dyn = update_dyn + do_thermo = .true. ; if (present(update_thermo)) do_thermo = update_thermo + ! This is benign but not necessary if ocean_model_init_sfc was called or if ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec @@ -517,26 +510,36 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & weight = 1.0 + call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time, & + OS%grid, OS%forcing_CSp) + if (OS%fluxes%fluxes_used) then - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) ! Needed to allow diagnostics in convert_IOB - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%forces, OS%fluxes, index_bnds, OS%Time, & - OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) + if (do_thermo) & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, & + OS%grid, OS%forcing_CSp, OS%sfc_state, & + OS%restore_salinity, OS%restore_temp) ! Add ice shelf fluxes if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_thermo) & + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_dyn) & + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) endif - if (OS%icebergs_apply_rigid_boundary) then - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%fluxes, OS%use_ice_shelf, & - OS%density_iceberg, OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, & - dt_coupling, OS%berg_area_threshold) + if (OS%icebergs_alter_ocean) then + if (do_dyn) & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + if (do_thermo) & + call iceberg_fluxes(OS%grid, OS%fluxes, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif ! Fields that exist in both the forcing and mech_forcing types must be copied. - call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) + call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid, skip_pres=.true.) #ifdef _USE_GENERIC_TRACER + call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes #endif ! Indicate that there are new unused fluxes. @@ -544,20 +547,28 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%fluxes%dt_buoy_accum = dt_coupling else OS%flux_tmp%C_p = OS%fluxes%C_p - call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%forces, OS%flux_tmp, index_bnds, OS%Time, & + if (do_thermo) & + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, & OS%grid, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) + if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_thermo) & + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + if (do_dyn) & + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) endif - if (OS%icebergs_apply_rigid_boundary) then - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf, OS%density_iceberg, & - OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, dt_coupling, OS%berg_area_threshold) + if (OS%icebergs_alter_ocean) then + if (do_dyn) & + call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + if (do_thermo) & + call iceberg_fluxes(OS%grid, OS%flux_tmp, OS%use_ice_shelf, & + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, dt_coupling, OS%grid, weight) ! Some of the fields that exist in both the forcing and mech_forcing types - ! are time-averages must be copied back to the forces type. + ! (e.g., ustar) are time-averages must be copied back to the forces type. call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) #ifdef _USE_GENERIC_TRACER @@ -567,18 +578,28 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%GV%Rho0) call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) + if (OS%use_waves) then + call Update_Surface_Waves(OS%grid, OS%GV, OS%time, ocean_coupling_time_step, OS%waves) + endif + if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%fluxes, & - OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) endif call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time - if(OS%offline_tracer_mode) then + if (OS%offline_tracer_mode) then call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) + elseif ((.not.do_thermo) .or. (.not.do_dyn)) then + ! The call sequence is being orchestrated from outside of update_ocean_model. + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & + reset_therm=Ocn_fluxes_used) + !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -602,16 +623,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & - do_dynamics=.false., do_thermodynamics=.true., & + Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & - do_dynamics=.true., do_thermodynamics=.false., & + Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & - do_dynamics=.true., do_thermodynamics=.false., & + Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) step_thermo = .false. @@ -628,7 +649,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & - do_dynamics=.false., do_thermodynamics=.true., & + Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif endif @@ -663,6 +684,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & end subroutine update_ocean_model ! NAME="update_ocean_model" + !======================================================================= ! ! @@ -670,113 +692,15 @@ end subroutine update_ocean_model ! write out restart file. ! Arguments: ! timestamp (optional, intent(in)) : A character string that represents the model time, -! used for writing restart. timestamp will append to +! used for writing restart. timestamp will prepend to ! the any restart file name as a prefix. ! ! - -subroutine add_berg_flux_to_shelf(G, forces, fluxes, use_ice_shelf, density_ice, kv_ice, & - latent_heat_fusion, sfc_state, time_step, berg_area_threshold) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. - real, intent(in) :: kv_ice !< The viscosity of ice, in m2 s-1. - real, intent(in) :: density_ice !< A typical density of ice, in kg m-3. - real, intent(in) :: latent_heat_fusion !< The latent heat of fusion, in J kg-1. - real, intent(in) :: time_step !< The coupling time step, in s. - real, intent(in) :: berg_area_threshold !< Area threshold for zeroing fluxes below iceberg -! Arguments: -! (in) fluxes - A structure of surface fluxes that may be used. -! (in) G - The ocean's grid structure. - real :: fraz ! refreezing rate in kg m-2 s-1 - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - !This routine adds iceberg data to the ice shelf data (if ice shelf is used) - !which can then be used to change the top of ocean boundary condition used in - !the ocean model. This routine is taken from the add_shelf_flux subroutine - !within the ice shelf model. - - if (.not. (((associated(fluxes%frac_shelf_h) .and. associated(forces%frac_shelf_u)) & - .and.(associated(forces%frac_shelf_v) .and. associated(fluxes%ustar_shelf)))& - .and.(associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)))) return - - if (.not.(associated(fluxes%area_berg) .and. associated(fluxes%ustar_berg) .and. & - associated(fluxes%mass_berg) ) ) return - - if (.not. use_ice_shelf) then - fluxes%frac_shelf_h(:,:) = 0. - forces%frac_shelf_u(:,:) = 0. - forces%frac_shelf_v(:,:) = 0. - fluxes%ustar_shelf(:,:) = 0. - forces%rigidity_ice_u(:,:) = 0. - forces%rigidity_ice_v(:,:) = 0. - endif - - do j=jsd,jed ; do i=isd,ied - if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = fluxes%frac_shelf_h(i,j) + fluxes%area_berg(i,j) - fluxes%ustar_shelf(i,j) = fluxes%ustar_shelf(i,j) + fluxes%ustar_berg(i,j) - enddo ; enddo - do j=jsd,jed ; do I=isd,ied-1 - forces%frac_shelf_u(I,j) = 0.0 - if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = forces%frac_shelf_u(I,j) + & - (((fluxes%area_berg(i,j)*G%areaT(i,j)) + (fluxes%area_berg(i+1,j)*G%areaT(i+1,j))) / & - (G%areaT(i,j) + G%areaT(i+1,j)) ) - !### Either the min here or the max below must be wrong, but is either right? -RWH - forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) +((kv_ice / density_ice) * & - min(fluxes%mass_berg(i,j), fluxes%mass_berg(i+1,j))) - enddo ; enddo - do J=jsd,jed-1 ; do i=isd,ied - forces%frac_shelf_v(i,J) = 0.0 - if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = forces%frac_shelf_v(i,J) + & - (((fluxes%area_berg(i,j)*G%areaT(i,j)) + (fluxes%area_berg(i,j+1)*G%areaT(i,j+1))) / & - (G%areaT(i,j) + G%areaT(i,j+1)) ) - !### Either the max here or the min above must be wrong, but is either right? -RWH - forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) +((kv_ice / density_ice) * & - max(fluxes%mass_berg(i,j), fluxes%mass_berg(i,j+1))) - enddo ; enddo - call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) - - !Zero'ing out other fluxes under the tabular icebergs - if (berg_area_threshold >= 0.) then - do j=jsd,jed ; do i=isd,ied - if (fluxes%frac_shelf_h(i,j) > berg_area_threshold) then !Only applying for ice shelf covering most of cell - - if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 - if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 - if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 - if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 - - ! Add frazil formation diagnosed by the ocean model (J m-2) in the - ! form of surface layer evaporation (kg m-2 s-1). Update lprec in the - ! control structure for diagnostic purposes. - - if (associated(sfc_state%frazil)) then - fraz = sfc_state%frazil(i,j) / time_step / latent_heat_fusion - if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz - !CS%lprec(i,j)=CS%lprec(i,j) - fraz - sfc_state%frazil(i,j) = 0.0 - endif - - !Alon: Should these be set to zero too? - if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 - if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 - endif - enddo ; enddo - endif - -end subroutine add_berg_flux_to_shelf - subroutine ocean_model_restart(OS, timestamp) - type(ocean_state_type), pointer :: OS - character(len=*), intent(in), optional :: timestamp + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state being saved to a restart file + character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be + !! prepended to the file name. (Currently this is unused.) if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& @@ -888,10 +812,11 @@ end subroutine ocean_model_save_restart subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & gas_fields_ocn) - type(domain2D), intent(in) :: input_domain + type(domain2D), intent(in) :: input_domain type(ocean_public_type), intent(inout) :: Ocean_sfc - type(diag_ctrl), intent(in) :: diag - logical, intent(in), optional :: maskmap(:,:) + type(diag_ctrl), intent(in) :: diag + logical, dimension(:,:), & + optional, intent(in) :: maskmap type(coupler_1d_bc_type), & optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate @@ -905,7 +830,7 @@ 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 + if (PRESENT(maskmap)) then 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) @@ -1166,9 +1091,9 @@ subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) case('mask') array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) !OR same result -! do j=g_jsc,g_jec; do i=g_isc,g_iec +! do j=g_jsc,g_jec ; do i=g_isc,g_iec ! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) -! enddo; enddo +! enddo ; enddo case('t_surf') array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET case('t_pme') diff --git a/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 index 66b2463ae7..5494954398 100644 --- a/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/ice_solo_driver/atmos_ocean_fluxes.F90 @@ -10,21 +10,23 @@ module atmos_ocean_fluxes_mod contains +!> This subroutine duplicates an interface used by the FMS coupler, but only +!! returns a value of -1. None of the arguments are used for anything. function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, & param, flag, ice_restart_file, ocean_restart_file, & units, caller, verbosity) result (coupler_index) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: flux_type - character(len=*), intent(in) :: implementation - integer, intent(in), optional :: atm_tr_index - real, intent(in), dimension(:), optional :: param - logical, intent(in), dimension(:), optional :: flag - character(len=*), intent(in), optional :: ice_restart_file - character(len=*), intent(in), optional :: ocean_restart_file - character(len=*), intent(in), optional :: units - character(len=*), intent(in), optional :: caller - integer, intent(in), optional :: verbosity + character(len=*), intent(in) :: name !< An unused argument + character(len=*), intent(in) :: flux_type !< An unused argument + character(len=*), intent(in) :: implementation !< An unused argument + integer, optional, intent(in) :: atm_tr_index !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument + logical, dimension(:), optional, intent(in) :: flag !< An unused argument + character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument + character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument + character(len=*), optional, intent(in) :: units !< An unused argument + character(len=*), optional, intent(in) :: caller !< An unused argument + integer, optional, intent(in) :: verbosity !< An unused argument ! None of these arguments are used for anything. diff --git a/config_src/ice_solo_driver/coupler_types.F90 b/config_src/ice_solo_driver/coupler_types.F90 index bc4a941b04..99a74e085c 100644 --- a/config_src/ice_solo_driver/coupler_types.F90 +++ b/config_src/ice_solo_driver/coupler_types.F90 @@ -68,7 +68,8 @@ module coupler_types_mod type, public :: coupler_3d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type @@ -115,7 +116,8 @@ module coupler_types_mod type, public :: coupler_2d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type @@ -156,7 +158,8 @@ module coupler_types_mod type, public :: coupler_1d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized end type coupler_1d_bc_type @@ -291,10 +294,11 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_1d_2d):' @@ -310,7 +314,7 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_1d_2d @@ -340,10 +344,11 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_1d_3d):' @@ -360,7 +365,7 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_1d_3d @@ -383,10 +388,11 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_2d_2d):' @@ -402,7 +408,7 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_2d_2d @@ -432,10 +438,11 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_2d_3d):' @@ -452,7 +459,7 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_2d_3d @@ -475,10 +482,11 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_3d_2d):' @@ -494,7 +502,7 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_3d_2d @@ -524,10 +532,11 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_3d_3d):' @@ -544,7 +553,7 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_3d_3d @@ -1174,8 +1183,10 @@ subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: copy_bc @@ -1249,8 +1260,10 @@ subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: copy_bc @@ -1329,8 +1342,10 @@ subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd @@ -1563,8 +1578,10 @@ subroutine CT_rescale_data_2d(var, scale, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: do_bc @@ -1640,8 +1657,10 @@ subroutine CT_rescale_data_3d(var, scale, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: do_bc @@ -1718,8 +1737,10 @@ subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1802,8 +1823,10 @@ subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1893,8 +1916,10 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1946,7 +1971,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi elseif ((1+var_in%ied-var_in%isd) == size(weights,1)) then iow = 1 + (var_in%isc - var_in%isd) - var%isc else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size of a computational or data domain.") + call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size "//& + "of a computational or data domain.") endif if ((1+var%jec-var%jsc) == size(weights,2)) then jow = 1 - var%jsc @@ -1955,7 +1981,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi elseif ((1+var_in%jed-var_in%jsd) == size(weights,2)) then jow = 1 + (var_in%jsc - var_in%jsd) - var%jsc else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size of a computational or data domain.") + call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size "//& + "of a computational or data domain.") endif io1 = var_in%isc - var%isc ; jo1 = var_in%jsc - var%jsc ; kow = 1 - var_in%ks @@ -2720,7 +2747,8 @@ end subroutine CT_set_data_3d !> This routine registers the diagnostics of a coupler_2d_bc_type. subroutine CT_set_diags_2d(var, diag_name, axes, time) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -2746,7 +2774,8 @@ end subroutine CT_set_diags_2d !> This routine registers the diagnostics of a coupler_3d_bc_type. subroutine CT_set_diags_3d(var, diag_name, axes, time) type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -3106,9 +3135,9 @@ end subroutine CT_restore_state_3d !> This subroutine potentially overrides the values in a coupler_2d_bc_type subroutine CT_data_override_2d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_2d_bc_type), intent(in) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time integer :: m, n @@ -3120,9 +3149,9 @@ end subroutine CT_data_override_2d !> This subroutine potentially overrides the values in a coupler_3d_bc_type subroutine CT_data_override_3d(gridname, var, Time) - character(len=3), intent(in) :: gridname !< 3-character long model grid ID - type(coupler_3d_bc_type), intent(in) :: var !< BC_type structure to override - type(time_type), intent(in) :: time !< The current model time + character(len=3), intent(in) :: gridname !< 3-character long model grid ID + type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure to override + type(time_type), intent(in) :: time !< The current model time integer :: m, n diff --git a/config_src/ice_solo_driver/ice_shelf_driver.F90 b/config_src/ice_solo_driver/ice_shelf_driver.F90 index 628b138639..7bfc7ec5ad 100644 --- a/config_src/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/ice_solo_driver/ice_shelf_driver.F90 @@ -265,7 +265,8 @@ program SHELF_main Time_end = daymax endif - if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), "TIme_end", time_type_to_real(Time_end) + if (is_root_pe()) print *,"Time_step_shelf", time_type_to_real(Time_step_shelf), & + "TIme_end", time_type_to_real(Time_end) if (Time >= Time_end) call MOM_error(FATAL, & "MOM_driver: The run has been started at or after the end time of the run.") diff --git a/config_src/ice_solo_driver/user_surface_forcing.F90 b/config_src/ice_solo_driver/user_surface_forcing.F90 index 1139070560..6a70999d50 100644 --- a/config_src/ice_solo_driver/user_surface_forcing.F90 +++ b/config_src/ice_solo_driver/user_surface_forcing.F90 @@ -22,8 +22,8 @@ module user_surface_forcing !* * !* USER_buoyancy forcing is used to set the surface buoyancy * !* forcing, which may include a number of fresh water flux fields * -!* (evap, liq_precip, froz_precip, liq_runoff, froz_runoff, and * -!* virt_precip) and the surface heat fluxes (sw, lw, latent and sens) * +!* (evap, lprec, fprec, lrunoff, frunoff, and * +!* vprec) and the surface heat fluxes (sw, lw, latent and sens) * !* if temperature and salinity are state variables, or it may simply * !* be the buoyancy flux if it is not. This routine also has coded a * !* restoring to surface values of temperature and salinity. * @@ -44,13 +44,14 @@ module user_surface_forcing !* * !********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID 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_file_parser, only : get_param, param_file_type, log_version use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data +use MOM_io, only : file_exists, read_data use MOM_time_manager, only : time_type, operator(+), operator(/), get_time use MOM_tracer_flow_control, only : call_tracer_set_forcing use MOM_tracer_flow_control, only : tracer_flow_control_CS @@ -84,14 +85,17 @@ module user_surface_forcing contains +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy. +!! These are the stresses in the direction of the model grid (i.e. the same +!! direction as the u- and v- velocities.) They are both in Pa. subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by - !! a previous call to user_surface_forcing_init + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. ! These are the stresses in the direction of the model grid (i.e. the same @@ -121,6 +125,9 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + ! Allocate the forcing arrays, if necessary. + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + ! Set the surface wind stresses, in units of Pa. A positive taux ! accelerates the ocean to the (pseudo-)east. @@ -144,15 +151,19 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) end subroutine USER_wind_forcing +!> This subroutine specifies the current surface fluxes of buoyancy or +!! temperature and fresh water. It may also be modified to add +!! surface fluxes of user provided tracers. subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine specifies the current surface fluxes of buoyancy or ! temperature and fresh water. It may also be modified to add @@ -161,9 +172,9 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! When temperature is used, there are long list of fluxes that need to be ! set - essentially the same as for a full coupled model, but most of these ! can be simply set to zero. The net fresh water flux should probably be -! set in fluxes%evap and fluxes%liq_precip, with any salinity restoring -! appearing in fluxes%virt_precip, and the other water flux components -! (froz_precip, liq_runoff and froz_runoff) left as arrays full of zeros. +! set in fluxes%evap and fluxes%lprec, with any salinity restoring +! appearing in fluxes%vprec, and the other water flux components +! (fprec, lrunoff and frunoff) left as arrays full of zeros. ! Evap is usually negative and precip is usually positive. All heat fluxes ! 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. @@ -201,19 +212,19 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%liq_precip, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%froz_precip, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%liq_runoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%froz_runoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%virt_precip, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif @@ -226,10 +237,10 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Fluxes of fresh water through the surface are in units of kg m-2 s-1 ! and are positive downward - i.e. evaporation should be negative. fluxes%evap(i,j) = -0.0 * G%mask2dT(i,j) - fluxes%liq_precip(i,j) = 0.0 * G%mask2dT(i,j) + fluxes%lprec(i,j) = 0.0 * G%mask2dT(i,j) - ! virt_precip will be set later, if it is needed for salinity restoring. - fluxes%virt_precip(i,j) = 0.0 + ! vprec will be set later, if it is needed for salinity restoring. + fluxes%vprec(i,j) = 0.0 ! Heat fluxes are in units of W m-2 and are positive into the ocean. fluxes%lw(i,j) = 0.0 * G%mask2dT(i,j) @@ -247,7 +258,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_restore, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & @@ -260,9 +271,9 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) Temp_restore = 0.0 Salin_restore = 0.0 - fluxes%heat_restore(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & + fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%virt_precip(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / & (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo @@ -287,24 +298,15 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine USER_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.ASSOCIATED(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> This subroutine initializes the USER_surface_forcing module subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(user_surface_forcing_CS), pointer :: CS + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. + type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to + !! the control structure for this module + ! Arguments: Time - The current model time. ! (in) G - The ocean's grid structure. ! (in) param_file - A structure indicating the open file to parse for @@ -330,18 +332,20 @@ subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state \n"//& "variables.", default=.true.) + call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default = 9.80) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to \n"//& "calculate accelerations and the mass for conservation \n"//& "properties, or with BOUSSINSEQ false to convert some \n"//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0) + call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & + "The background gustiness in the winds.", units="Pa", & + default=0.02) + call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back \n"//& "toward some specified surface state with a rate \n"//& diff --git a/config_src/mct_driver/MOM_ocean_model.F90 b/config_src/mct_driver/MOM_ocean_model.F90 new file mode 100644 index 0000000000..c894f42270 --- /dev/null +++ b/config_src/mct_driver/MOM_ocean_model.F90 @@ -0,0 +1,1037 @@ +module MOM_ocean_model + +! This file is part of MOM6. See LICENSE.md for the license. + +!----------------------------------------------------------------------- +! +! This is the top level module for the MOM6 ocean model. It contains routines +! for initialization, termination and update of ocean model state. This +! particular version wraps all of the calls for MOM6 in the calls that had +! been used for MOM4. +! +! Robert Hallberg +! +! +! +! This code is a stop-gap wrapper of the MOM6 code to enable it to be called +! in the same way as MOM4. +! + +use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end +use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization +use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized +use MOM, only : get_ocean_stocks, step_offline +use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf +use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners, fill_symmetric_edges +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : callTree_enter, callTree_leave +use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_accumulate, copy_common_forcing_fields +use MOM_forcing_type, only : copy_back_forcing_fields, set_net_mass_forcing +use MOM_forcing_type, only : set_derived_forcing_fields +use MOM_forcing_type, only : forcing_diagnostics, mech_forcing_diags +use MOM_forcing_type, only : allocate_mech_forcing +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : close_file, file_exists, read_data, write_version_number +use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS +use MOM_restart, only : MOM_restart_CS, save_restart +use MOM_string_functions, only : uppercase +use MOM_surface_forcing, only : surface_forcing_init +use MOM_surface_forcing, only : convert_IOB_to_fluxes +use MOM_surface_forcing, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum +use MOM_surface_forcing, only : ice_ocean_boundary_type, surface_forcing_CS +use MOM_surface_forcing, only : forcing_save_restart +use MOM_time_manager, only : time_type, get_time, set_time, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) +use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real +use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_init +use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ice_shelf, only : initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS +use MOM_ice_shelf, only : add_shelf_forces, ice_shelf_end, ice_shelf_save_restart +use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type +use coupler_types_mod, only : coupler_type_spawn, coupler_type_write_chksums +use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data +use coupler_types_mod, only : coupler_type_set_diags, coupler_type_send_data +use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain +use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain +use fms_mod, only : stdout +use mpp_mod, only : mpp_chksum +use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct +use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init +use MOM_wave_interface, only : MOM_wave_interface_init_lite, Update_Surface_Waves + +! MCT specfic routines +use ocn_cpl_indices, only : cpl_indices_type +use MOM_coms, only : reproducing_sum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_spatial_means, only : adjust_area_mean_to_zero +use MOM_diag_mediator, only : safe_alloc_ptr +use MOM_domains, only : MOM_infra_end +use user_revise_forcing, only : user_alter_forcing +use data_override_mod, only : data_override + +! FMS modules +use time_interp_external_mod, only : time_interp_external + +#include + +#ifdef _USE_GENERIC_TRACER +use MOM_generic_tracer, only : MOM_generic_tracer_fluxes_accumulate +#endif + +implicit none ; public + +public ocean_model_init, ocean_model_end, update_ocean_model +public get_ocean_grid ! add by Jiande +public ocean_model_save_restart, Ocean_stock_pe +public ocean_model_init_sfc, ocean_model_flux_init +public ocean_model_restart +public ocean_public_type_chksum +public ocean_model_data_get +public ice_ocn_bnd_type_chksum + +interface ocean_model_data_get + module procedure ocean_model_data1D_get + module procedure ocean_model_data2D_get +end interface + +!> This type is used for communication with other components via the FMS coupler. +!! The element names and types can be changed only with great deliberation, hence +!! the persistnce of things like the cutsy element name "avg_kount". +type, public :: ocean_public_type + type(domain2d) :: Domain !< The domain for the surface fields. + logical :: is_ocean_pe !! .true. on processors that run the ocean model. + character(len=32) :: instance_name = '' !< A name that can be used to identify + !! this instance of an ocean model, for example + !! in ensembles when writing messages. + integer, pointer, dimension(:) :: pelist => NULL() !< The list of ocean PEs. + logical, pointer, dimension(:,:) :: maskmap =>NULL() !< A pointer to an array + !! indicating which logical processors are actually + !! used for the ocean code. The other logical + !! processors would be all land points and are not + !! assigned to actual processors. This need not be + !! assigned if all logical processors are used. + + integer :: stagger = -999 !< The staggering relative to the tracer points + !! points of the two velocity components. Valid entries + !! include AGRID, BGRID_NE, CGRID_NE, BGRID_SW, and CGRID_SW, + !! corresponding to the community-standard Arakawa notation. + !! (These are named integers taken from mpp_parameter_mod.) + !! Following MOM5, stagger is BGRID_NE by default when the + !! ocean is initialized, but here it is set to -999 so that + !! a global max across ocean and non-ocean processors can be + !! used to determine its value. + real, pointer, dimension(:,:) :: & + t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) + s_surf => NULL(), & !< SSS on t-cell (psu) + u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. + v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. + sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, + !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) + frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil + !! formation in the ocean. + area => NULL() !< cell area of the ocean surface, in m2. + type(coupler_2d_bc_type) :: fields !< A structure that may contain an + !! array of named tracer-related fields. + integer :: avg_kount !< Used for accumulating averages of this type. + integer, dimension(2) :: axes = 0 !< Axis numbers that are available + ! for I/O using this surface data. +end type ocean_public_type + +!> Contains information about the ocean state, although it is not necessary that +!! this is implemented with all models. This type is NOT private, and can therefore CANNOT vary +!! between different ocean models. +type, public :: ocean_state_type + logical :: is_ocean_PE = .false. !< True if this is an ocean PE. + type(time_type) :: Time !< The ocean model's time and master clock. + integer :: Restart_control !< An integer that is bit-tested to determine whether + !! incremental restart files are saved and whether they + !! have a time stamped name. +1 (bit 0) for generic + !! files and +2 (bit 1) for time-stamped files. A + !! restart file is saved at the end of a run segment + !! unless Restart_control is negative. + integer :: nstep = 0 !< The number of calls to update_ocean. + logical :: use_ice_shelf !< If true, the ice shelf model is enabled. + logical :: icebergs_apply_rigid_boundary !< If true, the icebergs can change ocean bd condition. + real :: kv_iceberg !< The viscosity of the icebergs in m2/s (for ice rigidity) + real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy + !! so that fluxes below are set to zero. (0.5 is a + !! good value to use. Not applied for negative values. + real :: latent_heat_fusion !< Latent heat of fusion + real :: density_iceberg !< A typical density of icebergs in kg/m3 (for ice rigidity) + type(ice_shelf_CS), pointer :: Ice_shelf_CSp => NULL() !< ice shelf structure. + logical :: restore_salinity !< If true, the coupled MOM driver adds a term to + !! restore salinity to a specified value. + logical :: restore_temp !< If true, the coupled MOM driver adds a term to + !! restore sst to a specified value. + real :: press_to_z !< A conversion factor between pressure and ocean + !! depth in m, usually 1/(rho_0*g), in m Pa-1. + real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. + logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode + !! with the barotropic and baroclinic dynamics, thermodynamics, + !! etc. stepped forward integrated in time. + !! If true, all of the above are bypassed with all + !! fields necessary to integrate only the tracer advection + !! and diffusion equation read in from files stored from + !! a previous integration of the prognostic model. + type(directories) :: dirs !< A structure containing several relevant directory paths. + type(mech_forcing) :: forces!< A structure with the driving mechanical surface forces + type(forcing) :: fluxes !< A structure containing pointers to + !! the ocean forcing fields. + type(forcing) :: flux_tmp !< A secondary structure containing pointers to the + !! ocean forcing fields for when multiple coupled + !! timesteps are taken per thermodynamic step. + type(surface) :: sfc_state !< A structure containing pointers to + !! the ocean surface state fields. + type(ocean_grid_type), pointer :: grid => NULL() !< A pointer to a grid structure + !! containing metrics and related information. + type(verticalGrid_type), pointer :: GV => NULL() !< A pointer to a vertical grid + !! structure containing metrics and related information. + type(MOM_control_struct), pointer :: MOM_CSp => NULL() + type(surface_forcing_CS), pointer :: forcing_CSp => NULL() + type(MOM_restart_CS), pointer :: & + restart_CSp => NULL() !< A pointer set 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 +end type ocean_state_type + +integer :: id_clock_forcing + +!======================================================================= +contains +!======================================================================= + +!======================================================================= +! +! +! +! Initialize the ocean model. +! + +!> Initializes the ocean model, including registering fields +!! for restarts and reading restart files if appropriate. +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) + type(ocean_public_type), target, & + intent(inout) :: Ocean_sfc !< A structure containing various + !! publicly visible ocean surface properties after initialization, + !! the data in this type is intent(out). + type(ocean_state_type), pointer :: OS !< A structure whose internal + !! contents are private to ocean_model_mod that may be used to + !! contain all information about the ocean's interior state. + type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar + type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. + type(coupler_1d_bc_type), & + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the + !! ocean and surface-ice fields that will participate + !! in the calculation of additional gas or other + !! tracer fluxes, and can be used to spawn related + !! internal variables in the ice model. + character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read + +! This subroutine initializes both the ocean state and the ocean surface type. +! Because of the way that indicies and domains are handled, Ocean_sfc must have +! been used in a previous call to initialize_ocean_type. + + real :: Rho0 !< The Boussinesq ocean density, in kg m-3. + real :: G_Earth !< The gravitational acceleration in m s-2. + !! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "ocean_model_init" !< This module's name. + character(len=48) :: stagger + logical :: use_temperature + integer :: secs, days + type(param_file_type) :: param_file !< A structure to parse for run-time parameters + + call callTree_enter("ocean_model_init(), ocn_comp_mct.F90") + if (associated(OS)) then + call MOM_error(WARNING, "ocean_model_init called with an associated "// & + "ocean_state_type structure. Model is already initialized.") + return + endif + allocate(OS) + + OS%is_ocean_pe = Ocean_sfc%is_ocean_pe + if (.not.OS%is_ocean_pe) return + + OS%Time = Time_in + call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & + OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + input_restart_file=input_restart_file, diag_ptr=OS%diag, & + count_calls=.true.) + call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, C_p=OS%fluxes%C_p, & + use_temp=use_temperature) + OS%C_p = OS%fluxes%C_p + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "RESTART_CONTROL", OS%Restart_control, & + "An integer whose bits encode which restart files are \n"//& + "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& + "(bit 0) for a non-time-stamped file. A restart file \n"//& + "will be saved at the end of the run segment for any \n"//& + "non-negative value.", default=1) + call get_param(param_file, mdl, "OCEAN_SURFACE_STAGGER", stagger, & + "A case-insensitive character string to indicate the \n"//& + "staggering of the surface velocity field that is \n"//& + "returned to the coupler. Valid values include \n"//& + "'A', 'B', or 'C'.", default="C") + if (uppercase(stagger(1:1)) == 'A') then + Ocean_sfc%stagger = AGRID + elseif (uppercase(stagger(1:1)) == 'B') then + Ocean_sfc%stagger = BGRID_NE + elseif (uppercase(stagger(1:1)) == 'C') then + Ocean_sfc%stagger = CGRID_NE + else + call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & + trim(stagger)//" is invalid.") + end if + + call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & + "If true, the coupled driver will add a globally-balanced \n"//& + "fresh-water flux that drives sea-surface salinity \n"//& + "toward specified values.", default=.false.) + call get_param(param_file, mdl, "RESTORE_TEMPERATURE",OS%restore_temp, & + "If true, the coupled driver will add a \n"//& + "heat flux that drives sea-surface temperauture \n"//& + "toward specified values.", default=.false.) + call get_param(param_file, mdl, "RHO_0", Rho0, & + "The mean ocean density used with BOUSSINESQ true to \n"//& + "calculate accelerations and the mass for conservation \n"//& + "properties, or with BOUSSINSEQ false to convert some \n"//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0) + call get_param(param_file, mdl, "G_EARTH", G_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default = 9.80) + + call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & + "If true, enables the ice shelf model.", default=.false.) + + call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_apply_rigid_boundary, & + "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) + + if (OS%icebergs_apply_rigid_boundary) then + call get_param(param_file, mdl, "KV_ICEBERG", OS%kv_iceberg, & + "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) + call get_param(param_file, mdl, "DENSITY_ICEBERGS", OS%density_iceberg, & + "A typical density of icebergs.", units="kg m-3", default=917.0) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", OS%latent_heat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf) + call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", OS%berg_area_threshold, & + "Fraction of grid cell which iceberg must occupy, so that fluxes \n"//& + "below berg are set to zero. Not applied for negative \n"//& + " values.", units="non-dim", default=-1.0) + endif + + OS%press_to_z = 1.0/(Rho0*G_Earth) + + ! Consider using a run-time flag to determine whether to do the diagnostic + ! vertical integrals, since the related 3-d sums are not negligible in cost. + call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & + do_integrals=.true., gas_fields_ocn=gas_fields_ocn) + + call surface_forcing_init(Time_in, OS%grid, param_file, OS%diag, & + OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) + + if (OS%use_ice_shelf) then + call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & + OS%diag, OS%forces, OS%fluxes) + endif + if (OS%icebergs_apply_rigid_boundary) then + !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) + !This assumes that the iceshelf and ocean are on the same grid. I hope this is true + if (.not. OS%use_ice_shelf) call allocate_forcing_type(OS%grid, OS%fluxes, ustar=.true., shelf=.true.) + endif + + if (associated(OS%grid%Domain%maskmap)) then + call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & + OS%diag, maskmap=OS%grid%Domain%maskmap, & + gas_fields_ocn=gas_fields_ocn) + else + call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & + OS%diag, gas_fields_ocn=gas_fields_ocn) + endif + + ! This call can only occur here if the coupler_bc_type variables have been + ! initialized already using the information from gas_fields_ocn. + if (present(gas_fields_ocn)) then + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + endif + + call close_param_file(param_file) + call diag_mediator_close_registration(OS%diag) + + call callTree_leave("ocean_model_init(") + +end subroutine ocean_model_init +! NAME="ocean_model_init" + +!======================================================================= +! +! +! +! Update in time the ocean model fields. This code wraps the call to step_MOM +! with MOM4's call. +! +! + +!> Updates the ocean model fields. This code wraps the call to step_MOM with MOM6's call. +!! It uses the forcing to advance the ocean model's state from the +!! input value of Ocean_state (which must be for time time_start_update) for a time interval +!! of Ocean_coupling_time_step, returning the publicly visible ocean surface properties in +!! Ocean_sfc and storing the new ocean properties in Ocean_state. +subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & + time_start_update, Ocean_coupling_time_step) + + type(ice_ocean_boundary_type), & + intent(in) :: Ice_ocean_boundary !< A structure containing the + !! various forcing fields coming from the ice. + + type(ocean_state_type), & + pointer :: OS !< A pointer to a private structure containing + !! the internal ocean state. + + type(ocean_public_type), & + intent(inout) :: Ocean_sfc !< A structure containing all the + !! publicly visible ocean surface fields after + !! a coupling time step. The data in this type is + !! intent out. + + type(time_type), intent(in) :: time_start_update !< The time at the beginning of the update step. + type(time_type), intent(in) :: Ocean_coupling_time_step !< The amount of time over + !! which to advance the ocean. + + ! local variables + type(time_type) :: Master_time !< This allows step_MOM to temporarily change + !! the time that is seen by internal modules. + type(time_type) :: Time1 !< The value of the ocean model's time at the + !! start of a call to step_MOM. + integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocn boundary type + real :: weight !< Flux accumulation weight + real :: time_step !< The time step of a call to step_MOM in seconds. + integer :: secs, days + integer :: is, ie, js, je + + call callTree_enter("update_ocean_model(), MOM_ocean_model.F90") + call get_time(Ocean_coupling_time_step, secs, days) + time_step = 86400.0*real(days) + real(secs) + + if (time_start_update /= OS%Time) then + call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& + "agree with time_start_update argument.") + endif + + if (.not.associated(OS)) then + call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & + "ocean_state_type structure. ocean_model_init must be "// & + "called first to allocate this structure.") + return + endif + + ! This is benign but not necessary if ocean_model_init_sfc was called or if + ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. + is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec + call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + ! Translate Ice_ocean_boundary into fluxes. + call mpp_get_compute_domain(Ocean_sfc%Domain, index_bnds(1), index_bnds(2), & + index_bnds(3), index_bnds(4)) + weight = 1.0 + + call convert_IOB_to_forces(Ice_ocean_boundary, OS%forces, index_bnds, OS%Time, & + OS%grid, OS%forcing_CSp) + + if (OS%fluxes%fluxes_used) then + + ! GMM, is enable_averaging needed now? + call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%diag) + + ! Import fluxes from coupler to ocean. Also, perform do SST and SSS restoring, if needed. + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, OS%Time, OS%grid, OS%forcing_CSp, & + OS%sfc_state, OS%restore_salinity, OS%restore_temp) + + ! Fields that exist in both the forcing and mech_forcing types must be copied. + call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) + +#ifdef _USE_GENERIC_TRACER + call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes +#endif + + ! Add ice shelf fluxes + if (OS%use_ice_shelf) then + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, time_step, OS%Ice_shelf_CSp) + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + endif + + ! GMM, check ocean_model_MOM.F90 to enable the following option + !if (OS%icebergs_apply_rigid_boundary) then + ! This assumes that the iceshelf and ocean are on the same grid. I hope this is true. + ! call add_berg_flux_to_shelf(OS%grid, OS%forces,OS%fluxes,OS%use_ice_shelf,OS%density_iceberg, & + ! OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) + !endif + + ! Indicate that there are new unused fluxes. + OS%fluxes%fluxes_used = .false. + OS%fluxes%dt_buoy_accum = time_step + + else + + OS%flux_tmp%C_p = OS%fluxes%C_p + + ! Import fluxes from coupler to ocean. Also, perform do SST and SSS restoring, if needed. + call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, OS%Time, OS%grid, OS%forcing_CSp, & + OS%sfc_state, OS%restore_salinity, OS%restore_temp) + + if (OS%use_ice_shelf) then + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, time_step, OS%Ice_shelf_CSp) + call add_shelf_forces(OS%grid, OS%Ice_shelf_CSp, OS%forces) + endif + + ! GMM, check ocean_model_MOM.F90 to enable the following option + !if (OS%icebergs_apply_rigid_boundary) then + !This assumes that the iceshelf and ocean are on the same grid. I hope this is true + ! call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf,OS%density_iceberg, & + ! OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) + !endif + + ! Accumulate the forcing over time steps + call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, time_step, OS%grid, weight) + + ! Some of the fields that exist in both the forcing and mech_forcing types + ! are time-averages must be copied back to the forces type. + call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) +#ifdef _USE_GENERIC_TRACER + call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average +#endif + endif + + call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%GV%Rho0) + call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) + + if (OS%nstep==0) then + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + endif + + call disable_averaging(OS%diag) + Master_time = OS%Time ; Time1 = OS%Time + + if(OS%offline_tracer_mode) then + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) + else + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) + endif + + OS%Time = Master_time + Ocean_coupling_time_step + OS%nstep = OS%nstep + 1 + + call enable_averaging(time_step, OS%Time, OS%diag) + call mech_forcing_diags(OS%forces, OS%fluxes, time_step, OS%grid, & + OS%diag, OS%forcing_CSp%handles) + call disable_averaging(OS%diag) + + if (OS%fluxes%fluxes_used) then + call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) + call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & + OS%grid, OS%diag, OS%forcing_CSp%handles) + call disable_averaging(OS%diag) + endif + +! Translate state into Ocean. +! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & +! Ice_ocean_boundary%p, OS%press_to_z) + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + + call callTree_leave("update_ocean_model()") + +end subroutine update_ocean_model +! NAME="update_ocean_model" + +!======================================================================= +! +! +! +! write out restart file. +! Arguments: +! timestamp (optional, intent(in)) : A character string that represents the model time, +! used for writing restart. timestamp will prepend to +! the any restart file name as a prefix. +! +! +subroutine ocean_model_restart(OS, timestamp) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state being saved to a restart file + character(len=*), optional, intent(in) :: timestamp !< An optional timestamp string that should be + !! prepended to the file name. (Currently this is unused.) + + if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & + call MOM_error(WARNING, "End of MOM_main reached with inconsistent "//& + "dynamics and advective times. Additional restart fields "//& + "that have not been coded yet would be required for reproducibility.") + if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_restart "//& + "was called with unused buoyancy fluxes. For conservation, the ocean "//& + "restart files can only be created after the buoyancy forcing is applied.") + + 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 subroutine ocean_model_restart +! NAME="ocean_model_restart" + +!======================================================================= +! +! +! +! Close down the ocean model +! + +!> Terminates the model run, saving the ocean state in a +!! restart file and deallocating any data associated with the ocean. +subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) + type(ocean_public_type), intent(inout) :: Ocean_sfc !< An ocean_public_type structure that is to be + !! deallocated upon termination. + type(ocean_state_type), pointer :: Ocean_state!< pointer to the structure containing the internal + ! !! ocean state to be deallocated upon termination. + type(time_type), intent(in) :: Time !< The model time, used for writing restarts. + + call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) + ! print time stats + call MOM_infra_end + call MOM_end(Ocean_state%MOM_CSp) + if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) + +end subroutine ocean_model_end +! NAME="ocean_model_end" + +!======================================================================= + +!> ocean_model_save_restart causes restart files associated with the ocean to be +!! written out. +subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (in). + type(time_type), intent(in) :: Time !< The model time at this call, needed for mpp_write calls. + character(len=*), optional, intent(in) :: directory !< An optional directory into which to + !! write these restart files. + character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a time-stamp) + !! to append to the restart file names. +! Arguments: Ocean_state - A structure containing the internal ocean state (in). +! (in) Time - The model time at this call. This is needed for mpp_write calls. +! (in, opt) directory - An optional directory into which to write these restart files. +! (in, opt) filename_suffix - An optional suffix (e.g., a time-stamp) to append +! to the restart file names. + +! Note: This is a new routine - it will need to exist for the new incremental +! checkpointing. It will also be called by ocean_model_end, giving the same +! restart behavior as now in FMS. + character(len=200) :: restart_dir + + if (.not.MOM_state_is_synchronized(OS%MOM_CSp)) & + call MOM_error(WARNING, "ocean_model_save_restart called with inconsistent "//& + "dynamics and advective times. Additional restart fields "//& + "that have not been coded yet would be required for reproducibility.") + if (.not.OS%fluxes%fluxes_used) call MOM_error(FATAL, "ocean_model_save_restart "//& + "was called with unused buoyancy fluxes. For conservation, the ocean "//& + "restart files can only be created after the buoyancy forcing is applied.") + + if (present(directory)) then + restart_dir = directory + else + restart_dir = OS%dirs%restart_output_dir + endif + + call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + + call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) + + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + +end subroutine ocean_model_save_restart + +!======================================================================= + +!> Initializes domain and state variables contained in the ocean public type. +subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & + gas_fields_ocn) + type(domain2D), intent(in) :: input_domain !< The FMS domain for the input structure + type(ocean_public_type), intent(inout) :: Ocean_sfc !< Ocean surface state + type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. + logical, intent(in), optional :: maskmap(:,:) !< A pointer to an array indicating which + !! logical processors are actually used for the ocean code. + type(coupler_1d_bc_type), & + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the + !! ocean and surface-ice fields that will participate + !! in the calculation of additional gas or other + !! tracer fluxes. + ! local variables + integer :: xsz, ysz, layout(2) + integer :: isc, iec, jsc, jec + + 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) + else + 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) + + allocate ( Ocean_sfc%t_surf (isc:iec,jsc:jec), & + Ocean_sfc%s_surf (isc:iec,jsc:jec), & + Ocean_sfc%u_surf (isc:iec,jsc:jec), & + Ocean_sfc%v_surf (isc:iec,jsc:jec), & + Ocean_sfc%sea_lev(isc:iec,jsc:jec), & + Ocean_sfc%area (isc:iec,jsc:jec), & + Ocean_sfc%frazil (isc:iec,jsc:jec)) + + Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model + Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models + Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav + Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model + Ocean_sfc%area = 0.0 + Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics + + if (present(gas_fields_ocn)) then + call coupler_type_spawn(gas_fields_ocn, Ocean_sfc%fields, (/isc,isc,iec,iec/), & + (/jsc,jsc,jec,jec/), suffix = '_ocn', as_needed=.true.) + endif + +end subroutine initialize_ocean_public_type + +!> Translates the coupler's ocean_data_type into MOM6's surface state variable. +!! This may eventually be folded into the MOM6's code that calculates the +!! surface state in the first place. +subroutine convert_state_to_ocean_type(state, Ocean_sfc, G, patm, press_to_z) + type(surface), intent(inout) :: state + type(ocean_public_type), target, intent(inout) :: Ocean_sfc !< Ocean surface state + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, optional, intent(in) :: patm(:,:) !< Atmospheric pressure. + real, optional, intent(in) :: press_to_z !< Factor to tranform atmospheric + !! pressure to z? + + ! local variables + real :: IgR0 + character(len=48) :: val_str + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + integer :: i, j, i0, j0, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + call pass_vector(state%u,state%v,G%Domain) + + call mpp_get_compute_domain(Ocean_sfc%Domain, isc_bnd, iec_bnd, & + jsc_bnd, jec_bnd) + if (present(patm)) then + ! Check that the inidicies in patm are (isc_bnd:iec_bnd,jsc_bnd:jec_bnd). + if (.not.present(press_to_z)) call MOM_error(FATAL, & + 'convert_state_to_ocean_type: press_to_z must be present if patm is.') + endif + + i0 = is - isc_bnd ; j0 = js - jsc_bnd + if (state%T_is_conT) then + ! Convert the surface T from conservative T to potential T. + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(state%SSS(i+i0,j+j0), & + state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%t_surf(i,j) = state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET + enddo ; enddo + endif + if (state%S_is_absS) then + ! Convert the surface S from absolute salinity to practical salinity. + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(state%SSS(i+i0,j+j0)) + enddo ; enddo + else + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%s_surf(i,j) = state%SSS(i+i0,j+j0) + enddo ; enddo + endif + + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%sea_lev(i,j) = state%sea_lev(i+i0,j+j0) + if (present(patm)) & + Ocean_sfc%sea_lev(i,j) = Ocean_sfc%sea_lev(i,j) + patm(i,j) * press_to_z + if (associated(state%frazil)) & + Ocean_sfc%frazil(i,j) = state%frazil(i+i0,j+j0) + Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) + enddo ; enddo + + if (Ocean_sfc%stagger == AGRID) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I-1+i0,j+j0)) + Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0,J-1+j0)) + enddo ; enddo + elseif (Ocean_sfc%stagger == BGRID_NE) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I+i0,j+j0+1)) + Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0+1,J+j0)) + enddo ; enddo + elseif (Ocean_sfc%stagger == CGRID_NE) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*state%u(I+i0,j+j0) + Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*state%v(i+i0,J+j0) + enddo ; enddo + else + write(val_str, '(I8)') Ocean_sfc%stagger + call MOM_error(FATAL, "convert_state_to_ocean_type: "//& + "Ocean_sfc%stagger has the unrecognized value of "//trim(val_str)) + endif + + if (coupler_type_initialized(state%tr_fields)) then + if (.not.coupler_type_initialized(Ocean_sfc%fields)) then + call MOM_error(FATAL, "convert_state_to_ocean_type: "//& + "Ocean_sfc%fields has not been initialized.") + endif + call coupler_type_copy_data(state%tr_fields, Ocean_sfc%fields) + endif + +end subroutine convert_state_to_ocean_type + +!> This subroutine extracts the surface properties from the ocean's internal +!! state and stores them in the ocean type returned to the calling ice model. +!! It has to be separate from the ocean_initialization call because the coupler +!! module allocates the space for some of these variables. +subroutine ocean_model_init_sfc(OS, Ocean_sfc) + type(ocean_state_type), pointer :: OS !< A pointer to the structure containing the + !! internal ocean state (in). + type(ocean_public_type), intent(inout) :: Ocean_sfc !< Ocean surface state + + integer :: is, ie, js, je + + is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec + call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + +end subroutine ocean_model_init_sfc +! + +!======================================================================= + +!> ocean_model_flux_init is used to initialize properties of the air-sea fluxes +!! as determined by various run-time parameters. It can be called from +!! non-ocean PEs, or PEs that have not yet been initialzed, and it can safely +!! be called multiple times. +subroutine ocean_model_flux_init(OS, verbosity) + type(ocean_state_type), optional, pointer :: OS !< An optional pointer to the ocean state, + !! used to figure out if this is an ocean PE that + !! has already been initialized. + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. + + logical :: OS_is_set + integer :: verbose + + OS_is_set = .false. ; if (present(OS)) OS_is_set = associated(OS) + + ! Use this to control the verbosity of output; consider rethinking this logic later. + verbose = 5 ; if (OS_is_set) verbose = 3 + if (present(verbosity)) verbose = verbosity + + call call_tracer_flux_init(verbosity=verbose) + +end subroutine ocean_model_flux_init + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +! Ocean_stock_pe - returns stocks of heat, water, etc. for conservation checks.! +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! +!> Ocean_stock_pe - returns the integrated stocks of heat, water, etc. for conservation checks. +!! Because of the way FMS is coded, only the root PE has the integrated amount, +!! while all other PEs get 0. +subroutine Ocean_stock_pe(OS, index, value, time_index) + use stock_constants_mod, only : ISTOCK_WATER, ISTOCK_HEAT,ISTOCK_SALT + type(ocean_state_type), pointer :: OS !< A structure containing the internal ocean state. + !! The data in OS is intent(in). + integer, intent(in) :: index !< The stock index for the quantity of interest. + real, intent(out) :: value !< Sum returned for the conservation quantity of interest. + integer, optional, intent(in) :: time_index !< An unused optional argument, present only for + !! interfacial compatibility with other models. +! Arguments: OS - A structure containing the internal ocean state. +! (in) index - Index of conservation quantity of interest. +! (in) value - Sum returned for the conservation quantity of interest. +! (in,opt) time_index - Index for time level to use if this is necessary. + + real :: salt + + value = 0.0 + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + select case (index) + case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in kg. + if (OS%GV%Boussinesq) then + call get_ocean_stocks(OS%MOM_CSp, mass=value, on_PE_only=.true.) + else ! In non-Boussinesq mode, the mass of salt needs to be subtracted. + call get_ocean_stocks(OS%MOM_CSp, mass=value, salt=salt, on_PE_only=.true.) + value = value - salt + endif + 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.) + case default ; value = 0.0 + end select + ! If the FMS coupler is changed so that Ocean_stock_PE is only called on + ! ocean PEs, uncomment the following and eliminate the on_PE_only flags above. + ! if (.not.is_root_pe()) value = 0.0 + +end subroutine Ocean_stock_pe + +subroutine ocean_model_data2D_get(OS,Ocean, name, array2D,isc,jsc) + use MOM_constants, only : CELSIUS_KELVIN_OFFSET + type(ocean_state_type), pointer :: OS + type(ocean_public_type), intent(in) :: Ocean + character(len=*) , intent(in) :: name + real, dimension(isc:,jsc:), intent(out):: array2D + integer , intent(in) :: isc,jsc + + integer :: g_isc, g_iec, g_jsc, g_jec,g_isd, g_ied, g_jsd, g_jed, i, j + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + +! The problem is %areaT is on MOM domain but Ice_Ocean_Boundary%... is on mpp domain. +! We want to return the MOM data on the mpp (compute) domain +! Get MOM domain extents + call mpp_get_compute_domain(OS%grid%Domain%mpp_domain, g_isc, g_iec, g_jsc, g_jec) + call mpp_get_data_domain (OS%grid%Domain%mpp_domain, g_isd, g_ied, g_jsd, g_jed) + + g_isc = g_isc-g_isd+1 ; g_iec = g_iec-g_isd+1 ; g_jsc = g_jsc-g_jsd+1 ; g_jec = g_jec-g_jsd+1 + + + select case(name) + case('area') + array2D(isc:,jsc:) = OS%grid%areaT(g_isc:g_iec,g_jsc:g_jec) + case('mask') + array2D(isc:,jsc:) = OS%grid%mask2dT(g_isc:g_iec,g_jsc:g_jec) +!OR same result +! do j=g_jsc,g_jec ; do i=g_isc,g_iec +! array2D(isc+i-g_isc,jsc+j-g_jsc) = OS%grid%mask2dT(i,j) +! enddo ; enddo + case('t_surf') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_pme') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_runoff') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('t_calving') + array2D(isc:,jsc:) = Ocean%t_surf(isc:,jsc:)-CELSIUS_KELVIN_OFFSET + case('btfHeat') + array2D(isc:,jsc:) = 0 + case('tlat') + array2D(isc:,jsc:) = OS%grid%geoLatT(g_isc:g_iec,g_jsc:g_jec) + case('tlon') + array2D(isc:,jsc:) = OS%grid%geoLonT(g_isc:g_iec,g_jsc:g_jec) + case('ulat') + array2D(isc:,jsc:) = OS%grid%geoLatCu(g_isc:g_iec,g_jsc:g_jec) + case('ulon') + array2D(isc:,jsc:) = OS%grid%geoLonCu(g_isc:g_iec,g_jsc:g_jec) + case('vlat') + array2D(isc:,jsc:) = OS%grid%geoLatCv(g_isc:g_iec,g_jsc:g_jec) + case('vlon') + array2D(isc:,jsc:) = OS%grid%geoLonCv(g_isc:g_iec,g_jsc:g_jec) + case('geoLatBu') + array2D(isc:,jsc:) = OS%grid%geoLatBu(g_isc:g_iec,g_jsc:g_jec) + case('geoLonBu') + array2D(isc:,jsc:) = OS%grid%geoLonBu(g_isc:g_iec,g_jsc:g_jec) + case('cos_rot') + array2D(isc:,jsc:) = OS%grid%cos_rot(g_isc:g_iec,g_jsc:g_jec) ! =1 + case('sin_rot') + array2D(isc:,jsc:) = OS%grid%sin_rot(g_isc:g_iec,g_jsc:g_jec) ! =0 + case default + call MOM_error(FATAL,'ocean_model_data2D_get: unknown argument name='//name) + end select +end subroutine ocean_model_data2D_get + +subroutine ocean_model_data1D_get(OS,Ocean, name, value) + type(ocean_state_type), pointer :: OS + type(ocean_public_type), intent(in) :: Ocean + character(len=*) , intent(in) :: name + real , intent(out):: value + + if (.not.associated(OS)) return + if (.not.OS%is_ocean_pe) return + + select case(name) + case('c_p') + value = OS%C_p + case default + call MOM_error(FATAL,'ocean_model_data1D_get: unknown argument name='//name) + end select +end subroutine ocean_model_data1D_get + +subroutine ocean_public_type_chksum(id, timestep, ocn) + + character(len=*), intent(in) :: id + integer , intent(in) :: timestep + type(ocean_public_type), intent(in) :: ocn + integer :: n,m, outunit + + outunit = stdout() + + write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + write(outunit,100) 'ocean%t_surf ',mpp_chksum(ocn%t_surf ) + write(outunit,100) 'ocean%s_surf ',mpp_chksum(ocn%s_surf ) + write(outunit,100) 'ocean%u_surf ',mpp_chksum(ocn%u_surf ) + write(outunit,100) 'ocean%v_surf ',mpp_chksum(ocn%v_surf ) + write(outunit,100) 'ocean%sea_lev ',mpp_chksum(ocn%sea_lev) + write(outunit,100) 'ocean%frazil ',mpp_chksum(ocn%frazil ) + + call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') +100 FORMAT(" CHECKSUM::",A20," = ",Z20) +end subroutine ocean_public_type_chksum + +!======================================================================= +! +! +! +! Obtain the ocean grid. +! +! +subroutine get_ocean_grid(OS, Gridp) + type(ocean_state_type) :: OS + type(ocean_grid_type) , pointer :: Gridp + + Gridp => OS%grid + return + +end subroutine get_ocean_grid +! NAME="get_ocean_grid" + +end module MOM_ocean_model diff --git a/config_src/mct_driver/MOM_surface_forcing.F90 b/config_src/mct_driver/MOM_surface_forcing.F90 new file mode 100644 index 0000000000..5c4a43bfc0 --- /dev/null +++ b/config_src/mct_driver/MOM_surface_forcing.F90 @@ -0,0 +1,1338 @@ +module MOM_surface_forcing + +! This file is part of MOM6. See LICENSE.md for the license. + +!### use MOM_controlled_forcing, only : apply_ctrl_forcing, register_ctrl_forcing_restarts +!### use MOM_controlled_forcing, only : controlled_forcing_init, controlled_forcing_end +!### use MOM_controlled_forcing, only : ctrl_forcing_CS +use MOM_coms, only : reproducing_sum +use MOM_constants, only : hlv, hlf +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT +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 +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags +use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type +use MOM_forcing_type, only : allocate_mech_forcing, deallocate_mech_forcing +use MOM_get_input, only : Get_MOM_Input, directories +use MOM_grid, only : ocean_grid_type +use MOM_io, only : slasher, write_version_number, MOM_read_data +use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS +use MOM_restart, only : restart_init_end, save_restart, restore_state +use MOM_string_functions, only : uppercase +use MOM_spatial_means, only : adjust_area_mean_to_zero +use MOM_variables, only : surface +use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init +use user_revise_forcing, only : user_revise_forcing_CS + +use coupler_types_mod, only : coupler_2d_bc_type, coupler_type_write_chksums +use coupler_types_mod, only : coupler_type_initialized, coupler_type_spawn +use coupler_types_mod, only : coupler_type_copy_data +use data_override_mod, only : data_override_init, data_override +use fms_mod, only : stdout +use fms_mod, only : read_data +use mpp_mod, only : mpp_chksum +use time_interp_external_mod, only : init_external_field, time_interp_external +use time_interp_external_mod, only : time_interp_external_init + +! MCT specfic routines +use ocn_cpl_indices, only : cpl_indices_type + +implicit none ; private + +#include + +public IOB_allocate +public convert_IOB_to_fluxes +public convert_IOB_to_forces +public surface_forcing_init +public ice_ocn_bnd_type_chksum +public forcing_save_restart +public apply_flux_adjustments + +!> Contains pointers to the forcing fields which may be used to drive MOM. +!! All fluxes are positive downward. +type, public :: surface_forcing_CS ; + integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integer values + !! from MOM_domains) to indicate the staggering of + !! the winds that are being provided in calls to + !! update_ocean_model. CIME uses AGRID, so this option + !! is being hard coded for now. + logical :: use_temperature !< If true, temp and saln used as state variables + real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). + ! smg: remove when have A=B code reconciled + logical :: bulkmixedlayer !< If true, model based on bulk mixed layer code + real :: Rho0 !< Boussinesq reference density (kg/m^3) + real :: area_surf = -1.0 !< total ocean surface area (m^2) + real :: latent_heat_fusion ! latent heat of fusion (J/kg) + real :: latent_heat_vapor ! latent heat of vaporization (J/kg) + real :: max_p_surf !< maximum surface pressure that can be + !! exerted by the atmosphere and floating sea-ice, + !! in Pa. This is needed because the FMS coupling + !! structure does not limit the water that can be + !! frozen out of the ocean and the ice-ocean heat + !! fluxes are treated explicitly. + logical :: use_limited_P_SSH !< If true, return the sea surface height with + !! the correction for the atmospheric (and sea-ice) + !! pressure limited by max_p_surf instead of the + !! full atmospheric pressure. The default is true. + real :: gust_const !< constant unresolved background gustiness for ustar (Pa) + logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied + !! from an input file. + real, pointer, dimension(:,:) :: & + TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the + !! bottom boundary layer by drag on the tidal flows, + !! in W m-2. + gust => NULL(), & !< spatially varying unresolved background + !! gustiness that contributes to ustar (Pa). + !! gust is used when read_gust_2d is true. + ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity (m/s) + real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) + real :: utide !< constant tidal velocity to use if read_tideamp + !! is false, in m s-1. + logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. + logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts + !! to damp surface deflections (especially surface + !! gravity waves). The default is false. + real :: Kv_sea_ice !< viscosity in sea-ice that resists sheared vertical motions (m^2/s) + real :: density_sea_ice !< typical density of sea-ice (kg/m^3). The value is + !! only used to convert the ice pressure into + !! appropriate units for use with Kv_sea_ice. + real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which + !! sea-ice viscosity becomes effective, in kg m-2, + !! typically of order 1000 kg m-2. + logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments + real :: Flux_const !< piston velocity for surface restoring (m/s) + logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux + logical :: adjust_net_srestore_to_zero !< adjust srestore to zero (for both salt_flux or vprec) + logical :: adjust_net_srestore_by_scaling !< adjust srestore w/o moving zero contour + logical :: adjust_net_fresh_water_to_zero !< adjust net surface fresh-water (w/ restoring) to zero + logical :: use_net_FW_adjustment_sign_bug ! use the wrong sign when adjusting net FW + logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour + logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil + !! criteria for salinity restoring. + real :: ice_salt_concentration !< salt concentration for sea ice (kg/kg) + logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas + real :: max_delta_srestore !< maximum delta salinity used for restoring + real :: max_delta_trestore !< maximum delta sst used for restoring + real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring + type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing + character(len=200) :: inputdir !< directory where NetCDF input files are + character(len=200) :: salt_restore_file !< filename for salt restoring data + character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file + logical :: mask_srestore ! if true, apply a 2-dimensional mask to the surface + ! salinity restoring fluxes. The masking file should be + ! in inputdir/salt_restore_mask.nc and the field should + ! be named 'mask' + real, pointer, dimension(:,:) :: srestore_mask => NULL() ! mask for SSS restoring + character(len=200) :: temp_restore_file !< filename for sst restoring data + character(len=30) :: temp_restore_var_name !< name of surface temperature in temp_restore_file + logical :: mask_trestore ! if true, apply a 2-dimensional mask to the surface + ! temperature restoring fluxes. The masking file should be + ! in inputdir/temp_restore_mask.nc and the field should + ! be named 'mask' + real, pointer, dimension(:,:) :: trestore_mask => NULL() ! mask for SST restoring + integer :: id_srestore = -1 !< id number for time_interp_external. + integer :: id_trestore = -1 !< id number for time_interp_external. + type(forcing_diags), public :: handles !< diagnostics handles + !### type(ctrl_forcing_CS), pointer :: ctrl_forcing_CSp => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< restart pointer + type(user_revise_forcing_CS), pointer :: urf_CS => NULL()!< user revise pointer +end type surface_forcing_CS + +! ice_ocean_boundary_type is a structure corresponding to forcing, but with +! the elements, units, and conventions that exactly conform to the use for +! MOM-based coupled models. +type, public :: ice_ocean_boundary_type + real, pointer, dimension(:,:) :: latent_flux =>NULL() !< latent flux (W/m2) + real, pointer, dimension(:,:) :: rofl_flux =>NULL() !< liquid runoff (W/m2) + real, pointer, dimension(:,:) :: rofi_flux =>NULL() !< ice runoff (W/m2) + real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress (Pa) + real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress (Pa) + real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux (W/m2) + real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux (kg/m2/s) + real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux (kg/m2/s) + real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_nir_dir =>NULL() !< direct Near InfraRed sw radiation (W/m2) + real, pointer, dimension(:,:) :: sw_flux_nir_dif =>NULL() !< diffuse Near InfraRed sw radiation (W/m2) + real, pointer, dimension(:,:) :: lprec =>NULL() !< mass flux of liquid precip (kg/m2/s) + real, pointer, dimension(:,:) :: fprec =>NULL() !< mass flux of frozen precip (kg/m2/s) + real, pointer, dimension(:,:) :: runoff =>NULL() !< mass flux of liquid runoff (kg/m2/s) + real, pointer, dimension(:,:) :: calving =>NULL() !< mass flux of frozen runoff (kg/m2/s) + real, pointer, dimension(:,:) :: ustar_berg =>NULL() !< frictional velocity beneath icebergs (m/s) + real, pointer, dimension(:,:) :: area_berg =>NULL() !< area covered by icebergs(m2/m2) + real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) + real, pointer, dimension(:,:) :: runoff_hflx =>NULL() !< heat content of liquid runoff (W/m2) + real, pointer, dimension(:,:) :: calving_hflx =>NULL() !< heat content of frozen runoff (W/m2) + real, pointer, dimension(:,:) :: p =>NULL() !< pressure of overlying ice and atmosphere + !< on ocean surface (Pa) + real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice (kg/m2) + real, pointer, dimension(:,:) :: ice_rigidity =>NULL() !< rigidity of the sea ice, sea-ice and + !! ice-shelves, expressed as a coefficient + !! for divergence damping, as determined + !! outside of the ocean model in (m3/s) + integer :: xtype !< The type of the exchange - REGRID, REDIST or DIRECT + type(coupler_2d_bc_type) :: fluxes !< A structure that may contain an array of + !! named fields used for passive tracer fluxes. + integer :: wind_stagger = -999 !< A flag indicating the spatial discretization of + !! wind stresses. This flag may be set by the + !! flux-exchange code, based on what the sea-ice + !! model is providing. Otherwise, the value from + !! the surface_forcing_CS is used. +end type ice_ocean_boundary_type + +integer :: id_clock_forcing + +!======================================================================= +contains +!======================================================================= + +!> This function has a few purposes: 1) it allocates and initializes the data +!! in the fluxes structure; 2) it imports surface fluxes using data from +!! the coupler; and 3) it can apply restoring in SST and SSS. +!! See \ref section_ocn_import for a summary of the surface fluxes that are +!! passed from MCT to MOM6, including fluxes that need to be included in +!! the future. +subroutine convert_IOB_to_fluxes(IOB, fluxes, Time, G, CS, & + sfc_state, restore_salt, restore_temp) + + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + + type(forcing), intent(inout) :: fluxes !< A structure containing pointers to + !! all possible mass, heat or salt flux forcing fields. + !! Unused fields have NULL ptrs. + + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + type(surface), intent(in) :: sfc_state !< A structure containing fields that describe the + !! surface state of the ocean. + logical, optional, intent(in) :: restore_salt !< If true, salinity is restored to a target value. + logical, optional, intent(in) :: restore_temp !< If true, temperature is restored to a target value. + + ! local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + data_restore, & ! The surface value toward which to restore (g/kg or degC) + SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value (deg C) + SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value (g/kg) + SSS_mean, & ! A (mean?) salinity about which to normalize local salinity + ! anomalies when calculating restorative precipitation anomalies (g/kg) + PmE_adj, & ! The adjustment to PminusE that will cause the salinity + ! to be restored toward its target value (kg/(m^2 * s)) + net_FW, & ! The area integrated net freshwater flux into the ocean (kg/s) + net_FW2, & ! The area integrated net freshwater flux into the ocean (kg/s) + work_sum, & ! A 2-d array that is used as the work space for a global + ! sum, used with units of m2 or (kg/s) + open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + logical :: restore_salinity ! local copy of the argument restore_salt, if it + ! is present, or false (no restoring) otherwise. + logical :: restore_sst ! local copy of the argument restore_temp, if it + ! is present, or false (no restoring) otherwise. + real :: delta_sss ! temporary storage for sss diff from restoring value + real :: delta_sst ! temporary storage for sst diff from restoring value + + real :: C_p ! heat capacity of seawater ( J/(K kg) ) + + call cpu_clock_begin(id_clock_forcing) + + 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 + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + + C_p = fluxes%C_p + open_ocn_mask(:,:) = 1.0 + pme_adj(:,:) = 0.0 + fluxes%vPrecGlobalAdj = 0.0 + fluxes%vPrecGlobalScl = 0.0 + fluxes%saltFluxGlobalAdj = 0.0 + fluxes%saltFluxGlobalScl = 0.0 + fluxes%netFWGlobalAdj = 0.0 + fluxes%netFWGlobalScl = 0.0 + + restore_salinity = .false. + if (present(restore_salt)) restore_salinity = restore_salt + restore_sst = .false. + if (present(restore_temp)) restore_sst = restore_temp + + ! allocation and initialization if this is the first time that this + ! flux type has been used. + if (fluxes%dt_buoy_accum < 0) then + call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & + ustar=.true., press=.true.) + + call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%sw_nir_dif,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + + call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) + + if (CS%allow_flux_adjustments) then + call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + endif + + 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 + + if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) + + fluxes%dt_buoy_accum = 0.0 + endif ! endif for allocation and initialization + + if (CS%allow_flux_adjustments) then + fluxes%heat_added(:,:)=0.0 + fluxes%salt_flux_added(:,:)=0.0 + endif + + if (CS%area_surf < 0.0) then + do j=js,je ; do i=is,ie + work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) + enddo; enddo + CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) + endif ! endif for allocation and initialization + + do j=js,je ; do i=is,ie + fluxes%salt_flux(i,j) = 0.0 + fluxes%vprec(i,j) = 0.0 + enddo; enddo + + ! Salinity restoring logic + if (restore_salinity) then + call time_interp_external(CS%id_srestore,Time,data_restore) + ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) + open_ocn_mask(:,:) = 1.0 + 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 + endif + if (CS%salt_restore_as_sflux) then + do j=js,je ; do i=is,ie + delta_sss = data_restore(i,j)- sfc_state%SSS(i,j) + 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)) *delta_sss ! kg Salt m-2 s-1 + 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) + fluxes%saltFluxGlobalAdj = 0. + else + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) + fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf + fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj + endif + endif + 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 + 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%Rho0*CS%Flux_const) * & + delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) + endif + 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) + fluxes%vPrecGlobalAdj = 0. + else + work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) + 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) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) + enddo; enddo + endif + endif + endif + endif + + ! SST restoring logic + if (restore_sst) then + call time_interp_external(CS%id_trestore,Time,data_restore) + do j=js,je ; do i=is,ie + delta_sst = data_restore(i,j)- sfc_state%SST(i,j) + 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%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 + enddo; enddo + endif + + !i0 = is - isc_bnd ; j0 = js - jsc_bnd ??? + i0 = 0; j0 = 0 ! TODO: is this right? + + do j=js,je ; do i=is,ie + ! liquid precipitation (rain) + if (associated(fluxes%lprec)) & + fluxes%lprec(i,j) = G%mask2dT(i,j) * IOB%lprec(i-i0,j-j0) + + ! frozen precipitation (snow) + if (associated(fluxes%fprec)) & + fluxes%fprec(i,j) = G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0) + + ! evaporation + if (associated(fluxes%evap)) & + fluxes%evap(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0) + + ! river runoff flux + if (associated(fluxes%lrunoff)) & + fluxes%lrunoff(i,j) = G%mask2dT(i,j) * IOB%rofl_flux(i-i0,j-j0) + + ! ice runoff flux + if (associated(fluxes%frunoff)) & + fluxes%frunoff(i,j) = G%mask2dT(i,j) * IOB%rofi_flux(i-i0,j-j0) + + ! GMM, we don't have an icebergs yet so the following is not needed + !if (((associated(IOB%ustar_berg) .and. (.not. associated(fluxes%ustar_berg))) & + ! .or. (associated(IOB%area_berg) .and. (.not. associated(fluxes%area_berg)))) & + ! .or. (associated(IOB%mass_berg) .and. (.not. associated(fluxes%mass_berg)))) & + ! call allocate_forcing_type(G, fluxes, iceberg=.true.) + !if (associated(IOB%ustar_berg)) & + ! fluxes%ustar_berg(i,j) = 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) + !if (associated(IOB%mass_berg)) & + ! fluxes%mass_berg(i,j) = 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 seeting these to zero for now. + if (associated(fluxes%heat_content_lrunoff)) & + fluxes%heat_content_lrunoff(i,j) = 0.0 * G%mask2dT(i,j) + + if (associated(fluxes%heat_content_frunoff)) & + fluxes%heat_content_frunoff(i,j) = 0.0 * G%mask2dT(i,j) + + ! longwave radiation, sum up and down (W/m2) + if (associated(fluxes%LW)) & + fluxes%LW(i,j) = G%mask2dT(i,j) * IOB%lw_flux(i-i0,j-j0) + + ! sensible heat flux (W/m2) + if (associated(fluxes%sens)) & + fluxes%sens(i,j) = G%mask2dT(i,j) * IOB%t_flux(i-i0,j-j0) + + ! latent heat flux (W/m^2) + if (associated(fluxes%latent)) & + fluxes%latent(i,j) = G%mask2dT(i,j) * IOB%latent_flux(i-i0,j-j0) + + if (associated(IOB%sw_flux_vis_dir)) & + fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dir(i-i0,j-j0) + if (associated(IOB%sw_flux_vis_dif)) & + fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_vis_dif(i-i0,j-j0) + if (associated(IOB%sw_flux_nir_dir)) & + fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dir(i-i0,j-j0) + if (associated(IOB%sw_flux_nir_dif)) & + fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * IOB%sw_flux_nir_dif(i-i0,j-j0) + + 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) + + ! salt flux + ! more salt restoring logic + if (associated(fluxes%salt_flux)) & + fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(IOB%salt_flux(i-i0,j-j0) + fluxes%salt_flux(i,j)) + + if (associated(fluxes%salt_flux_in)) & + fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*IOB%salt_flux(i-i0,j-j0) + + enddo; enddo + + ! adjust the NET fresh-water flux to zero, if flagged + if (CS%adjust_net_fresh_water_to_zero) then + do j=js,je ; do i=is,ie + net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & + (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) + ! The following contribution appears to be calculating the volume flux of sea-ice + ! melt. This calculation is clearly WRONG if either sea-ice has variable + ! salinity or the sea-ice is completely fresh. + ! Bob thinks this is trying ensure the net fresh-water of the ocean + sea-ice system + ! is constant. + ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA + if (associated(fluxes%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & + net_FW(i,j) = net_FW(i,j) + G%areaT(i,j) * & + (fluxes%salt_flux(i,j) / CS%ice_salt_concentration) + net_FW2(i,j) = net_FW(i,j)/G%areaT(i,j) + 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) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) + 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) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) + enddo; enddo + endif + endif + + if (CS%allow_flux_adjustments) then + ! Apply adjustments to fluxes + call apply_flux_adjustments(G, CS, Time, fluxes) + endif + + ! Allow for user-written code to alter fluxes after all the above + call user_alter_forcing(sfc_state, fluxes, Time, G, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) + +end subroutine convert_IOB_to_fluxes + +!======================================================================= + +!> This subroutine translates the Ice_ocean_boundary_type into a MOM +!! mechanical forcing type, including changes of units, sign conventions, +!! and putting the fields into arrays with MOM-standard halos. +subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, CS) + type(ice_ocean_boundary_type), & + target, intent(in) :: IOB !< An ice-ocean boundary type with fluxes to drive + !! the ocean in a coupled model + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + integer, dimension(4), intent(in) :: index_bounds !< The i- and j- size of the arrays in IOB. + type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the + !! salinity to the right time, when it is being restored. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a + !! previous call to surface_forcing_init. + + real, dimension(SZIB_(G),SZJB_(G)) :: & + taux_at_q, & ! Zonal wind stresses at q points (Pa) + tauy_at_q ! Meridional wind stresses at q points (Pa) + + real, dimension(SZI_(G),SZJ_(G)) :: & + rigidity_at_h, & ! Ice rigidity at tracer points (m3 s-1) + taux_at_h, & ! Zonal wind stresses at h points (Pa) + tauy_at_h ! Meridional wind stresses at h points (Pa) + + real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) + real :: Irho0 ! inverse of the mean density in (m^3/kg) + real :: taux2, tauy2 ! squared wind stresses (Pa^2) + real :: tau_mag ! magnitude of the wind stress (Pa) + real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) + real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) + real :: mass_ice ! mass of sea ice at a face (kg/m^2) + real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) + + integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) + 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 :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd + + call cpu_clock_begin(id_clock_forcing) + + 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 + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 + + !isc_bnd = index_bounds(1) ; iec_bnd = index_bounds(2) + !jsc_bnd = index_bounds(3) ; jec_bnd = index_bounds(4) + !i0 = is - isc_bnd ; j0 = js - jsc_bnd + i0 = 0; j0 = 0 ! TODO: is this right? + + Irho0 = 1.0/CS%Rho0 + + ! allocation and initialization if this is the first time that this + ! mechanical forcing type has been used. + if (.not.forces%initialized) then + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & + press=.true.) + call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) + call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) + if (CS%rigid_sea_ice) then + call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) + call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) + endif + + forces%initialized = .true. + endif + + if (associated(forces%rigidity_ice_u)) forces%rigidity_ice_u(:,:) = 0.0 + if (associated(forces%rigidity_ice_v)) forces%rigidity_ice_v(:,:) = 0.0 + + !applied surface pressure from atmosphere and cryosphere + !sea-level pressure (Pa) + do j=js,je ; do i=is,ie + if (associated(forces%p_surf_full) .and. associated(forces%p_surf)) then + forces%p_surf_full(i,j) = G%mask2dT(i,j) * IOB%p(i-i0,j-j0) + + if (CS%max_p_surf >= 0.0) then + forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) + else + forces%p_surf(i,j) = forces%p_surf_full(i,j) + endif + + if (CS%use_limited_P_SSH) then + forces%p_surf_SSH => forces%p_surf + else + forces%p_surf_SSH => forces%p_surf_full + endif + end if + end do; end do + + ! GMM, CIME uses AGRID. All the BGRID_NE code can be cleaned later + wind_stagger = AGRID + + if (wind_stagger == BGRID_NE) then + ! This is necessary to fill in the halo points. + taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 + endif + if (wind_stagger == AGRID) then + ! This is necessary to fill in the halo points. + taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 + endif + + ! obtain fluxes from IOB; note the staggering of indices + do j=js,je ; do i=is,ie + if (wind_stagger == BGRID_NE) then + if (associated(IOB%u_flux)) taux_at_q(I,J) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_q(I,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + elseif (wind_stagger == AGRID) then + if (associated(IOB%u_flux)) taux_at_h(i,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) tauy_at_h(i,j) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + else ! C-grid wind stresses. + if (associated(IOB%u_flux)) forces%taux(I,j) = IOB%u_flux(i-i0,j-j0) * CS%wind_stress_multiplier + if (associated(IOB%v_flux)) forces%tauy(i,J) = IOB%v_flux(i-i0,j-j0) * CS%wind_stress_multiplier + endif + + enddo ; enddo + + ! surface momentum stress related fields as function of staggering + if (wind_stagger == BGRID_NE) then + if (G%symmetric) & + call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) + call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) + + 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) & + 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 + + 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) & + 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 + + ! 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 + ! in regions of very weak winds. + + 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 + 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) + & + G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & + ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) + if (CS%read_gust_2d) gustiness = CS%gust(i,j) + endif + forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) + enddo; enddo + + elseif (wind_stagger == AGRID) then + call pass_vector(taux_at_h, tauy_at_h, G%Domain,stagger=AGRID) + + 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) & + 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 + + 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) & + 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 + + 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) + 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 + + else ! C-grid wind stresses. + if (G%symmetric) & + call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) + call pass_vector(forces%taux, forces%tauy, G%Domain) + + do j=js,je ; do i=is,ie + taux2 = 0.0 + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 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) & + 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)) + + if (CS%read_gust_2d) then + forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) + else + forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) + endif + enddo; enddo + + endif ! endif for wind related fields + + ! sea ice related dynamic fields + if (CS%rigid_sea_ice) then + call pass_var(forces%p_surf_full, G%Domain, halo=1) + I_GEarth = 1.0 / G%G_Earth + Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) + do I=is-1,ie ; do j=js,je + mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth + mass_eff = 0.0 + if (mass_ice > CS%rigid_sea_ice_mass) then + mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & + (mass_ice + CS%rigid_sea_ice_mass) + endif + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + Kv_rho_ice * mass_eff + enddo ; enddo + do i=is,ie ; do J=js-1,je + mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth + mass_eff = 0.0 + if (mass_ice > CS%rigid_sea_ice_mass) then + mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & + (mass_ice + CS%rigid_sea_ice_mass) + endif + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + Kv_rho_ice * mass_eff + enddo ; enddo + endif + + if (CS%allow_flux_adjustments) then + ! Apply adjustments to forces + call apply_force_adjustments(G, CS, Time, forces) + endif + +!### ! Allow for user-written code to alter fluxes after all the above +!### call user_alter_mech_forcing(forces, Time, G, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) +end subroutine convert_IOB_to_forces + +!======================================================================= + +!> Allocates ice-ocean boundary type containers and sets to 0. +subroutine IOB_allocate(IOB, isc, iec, jsc, jec) + type(ice_ocean_boundary_type), intent(inout) :: IOB !< An ice-ocean boundary type with fluxes to drive + integer, intent(in) :: isc, iec, jsc, jec !< The ocean's local grid size + + allocate ( IOB% latent_flux (isc:iec,jsc:jec), & + IOB% rofl_flux (isc:iec,jsc:jec), & + IOB% rofi_flux (isc:iec,jsc:jec), & + IOB% u_flux (isc:iec,jsc:jec), & + IOB% v_flux (isc:iec,jsc:jec), & + IOB% t_flux (isc:iec,jsc:jec), & + IOB% q_flux (isc:iec,jsc:jec), & + IOB% salt_flux (isc:iec,jsc:jec), & + IOB% lw_flux (isc:iec,jsc:jec), & + IOB% sw_flux_vis_dir (isc:iec,jsc:jec), & + IOB% sw_flux_vis_dif (isc:iec,jsc:jec), & + IOB% sw_flux_nir_dir (isc:iec,jsc:jec), & + IOB% sw_flux_nir_dif (isc:iec,jsc:jec), & + IOB% lprec (isc:iec,jsc:jec), & + IOB% fprec (isc:iec,jsc:jec), & + IOB% runoff (isc:iec,jsc:jec), & + IOB% ustar_berg (isc:iec,jsc:jec), & + IOB% area_berg (isc:iec,jsc:jec), & + IOB% mass_berg (isc:iec,jsc:jec), & + IOB% calving (isc:iec,jsc:jec), & + IOB% runoff_hflx (isc:iec,jsc:jec), & + IOB% calving_hflx (isc:iec,jsc:jec), & + IOB% mi (isc:iec,jsc:jec), & + IOB% p (isc:iec,jsc:jec)) + + IOB%latent_flux = 0.0 + IOB%rofl_flux = 0.0 + IOB%rofi_flux = 0.0 + IOB%u_flux = 0.0 + IOB%v_flux = 0.0 + IOB%t_flux = 0.0 + IOB%q_flux = 0.0 + IOB%salt_flux = 0.0 + IOB%lw_flux = 0.0 + IOB%sw_flux_vis_dir = 0.0 + IOB%sw_flux_vis_dif = 0.0 + IOB%sw_flux_nir_dir = 0.0 + IOB%sw_flux_nir_dif = 0.0 + IOB%lprec = 0.0 + IOB%fprec = 0.0 + IOB%runoff = 0.0 + IOB%ustar_berg = 0.0 + IOB%area_berg = 0.0 + IOB%mass_berg = 0.0 + IOB%calving = 0.0 + IOB%runoff_hflx = 0.0 + IOB%calving_hflx = 0.0 + IOB%mi = 0.0 + IOB%p = 0.0 + +end subroutine IOB_allocate + +!======================================================================= + +!> Adds flux adjustments obtained via data_override +!! Component name is 'OCN' +!! Available adjustments are: +!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) +!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) +subroutine apply_flux_adjustments(G, CS, Time, fluxes) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure + type(time_type), intent(in) :: Time !< Model time structure + type(forcing), optional, intent(inout) :: fluxes !< Surface fluxes structure + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) + real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Fluxes at h points (W m-2 or kg m-2 s-1) + + integer :: isc, iec, jsc, jec, i, j + real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + logical :: overrode_x, overrode_y, overrode_h + + isc = G%isc; iec = G%iec + jsc = G%jsc; jec = G%jec + + overrode_h = .false. + call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + + if (overrode_h) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + enddo; enddo + endif + + call pass_var(fluxes%heat_added, G%Domain) + + overrode_h = .false. + call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + + if (overrode_h) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + enddo; enddo + endif + + call pass_var(fluxes%salt_flux_added, G%Domain) + overrode_h = .false. + + call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) + + if (overrode_h) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) + enddo; enddo + endif + + call pass_var(fluxes%vprec, G%Domain) + +end subroutine apply_flux_adjustments + +!======================================================================= + +!> Adds mechanical forcing adjustments obtained via data_override +!! Component name is 'OCN' +!! Available adjustments are: +!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) +!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) +subroutine apply_force_adjustments(G, CS, Time, forces) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure + type(time_type), intent(in) :: Time !< Model time structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) + real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) + + integer :: isc, iec, jsc, jec, i, j + real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + logical :: overrode_x, overrode_y + + isc = G%isc; iec = G%iec ; jsc = G%jsc; jec = G%jec + + tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 + ! Either reads data or leaves contents unchanged + overrode_x = .false. ; overrode_y = .false. + call data_override('OCN', 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x) + call data_override('OCN', 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y) + + if (overrode_x .or. overrode_y) then + if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& + "Both taux_adj and tauy_adj must be specified, or neither, in data_table") + + ! Rotate winds + call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID, halo=1) + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 + dLonDx = G%geoLonCu(I,j) - G%geoLonCu(I-1,j) + dLonDy = G%geoLonCv(i,J) - G%geoLonCv(i,J-1) + rDlon = sqrt( dLonDx * dLonDx + dLonDy * dLonDy ) + if (rDlon > 0.) rDlon = 1. / rDlon + cosA = dLonDx * rDlon + sinA = dLonDy * rDlon + zonal_tau = tempx_at_h(i,j) + merid_tau = tempy_at_h(i,j) + tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau + tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau + enddo ; enddo + + ! Average to C-grid locations + do j=jsc,jec ; do I=isc-1,iec + forces%taux(I,j) = forces%taux(I,j) + 0.5 * ( tempx_at_h(i,j) + tempx_at_h(i+1,j) ) + enddo ; enddo + + do J=jsc-1,jec ; do i=isc,iec + forces%tauy(i,J) = forces%tauy(i,J) + 0.5 * ( tempy_at_h(i,j) + tempy_at_h(i,j+1) ) + enddo ; enddo + endif ! overrode_x .or. overrode_y + +end subroutine apply_force_adjustments + +!======================================================================= + +!> Saves restart fields associated with the forcing +subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & + filename_suffix) + type(surface_forcing_CS), pointer :: CS !< pointer to the control structure + !! returned by a previous call to + !! surface_forcing_init + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(time_type), intent(in) :: Time !< model time at this call + character(len=*), intent(in) :: directory !< optional directory into which + !! to write these restart files + logical, optional, intent(in) :: time_stamped !< If true, the restart file + !! names include a unique time + !! stamp + character(len=*), optional, intent(in) :: filename_suffix !< optional suffix + !! (e.g., a time-stamp) to append to the + !! restart file names + if (.not.associated(CS)) return + if (.not.associated(CS%restart_CSp)) return + call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) + +end subroutine forcing_save_restart + +!======================================================================= + +!> Initializes surface forcing: get relevant parameters and allocate arrays. +subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, restore_temp) + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + 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(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module + logical, optional, intent(in) :: restore_salt, restore_temp !< If present and true, + !! temp/salt restoring will be applied + + ! local variables + real :: utide !< The RMS tidal velocity, in m s-1. + type(directories) :: dirs + logical :: new_sim, iceberg_flux_diags + type(time_type) :: Time_frc + character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl = "ocn_comp_mct" ! This module's name. + character(len=48) :: stagger + character(len=240) :: basin_file + integer :: i, j, isd, ied, jsd, jed + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (associated(CS)) then + call MOM_error(WARNING, "surface_forcing_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + id_clock_forcing=cpu_clock_id('Ocean surface forcing', grain=CLOCK_SUBCOMPONENT) + call cpu_clock_begin(id_clock_forcing) + + CS%diag => diag + + call write_version_number (version) + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & + "The directory in which all input files are found.", & + default=".") + CS%inputdir = slasher(CS%inputdir) + call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & + "If true, Temperature and salinity are used as state \n"//& + "variables.", default=.true.) + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to \n"//& + "calculate accelerations and the mass for conservation \n"//& + "properties, or with BOUSSINSEQ false to convert some \n"//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf) + call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & + "The latent heat of fusion.", units="J/kg", default=hlv) + call get_param(param_file, mdl, "MAX_P_SURF", CS%max_p_surf, & + "The maximum surface pressure that can be exerted by the \n"//& + "atmosphere and floating sea-ice or ice shelves. This is \n"//& + "needed because the FMS coupling structure does not \n"//& + "limit the water that can be frozen out of the ocean and \n"//& + "the ice-ocean heat fluxes are treated explicitly. No \n"//& + "limit is applied if a negative value is used.", units="Pa", & + default=-1.0) + call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & + CS%adjust_net_srestore_to_zero, & + "If true, adjusts the salinity restoring seen to zero\n"//& + "whether restoring is via a salt flux or virtual precip.",& + default=restore_salt) + call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_BY_SCALING", & + CS%adjust_net_srestore_by_scaling, & + "If true, adjustments to salt restoring to achieve zero net are\n"//& + "made by scaling values without moving the zero contour.",& + default=.false.) + call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_TO_ZERO", & + CS%adjust_net_fresh_water_to_zero, & + "If true, adjusts the net fresh-water forcing seen \n"//& + "by the ocean (including restoring) to zero.", default=.false.) + call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & + CS%adjust_net_fresh_water_by_scaling, & + "If true, adjustments to net fresh water to achieve zero net are\n"//& + "made by scaling values without moving the zero contour.",& + default=.false.) + call get_param(param_file, mdl, "ICE_SALT_CONCENTRATION", & + CS%ice_salt_concentration, & + "The assumed sea-ice salinity needed to reverse engineer the \n"//& + "melt flux (or ice-ocean fresh-water flux).", & + units="kg/kg", default=0.005) + call get_param(param_file, mdl, "USE_LIMITED_PATM_SSH", CS%use_limited_P_SSH, & + "If true, return the sea surface height with the \n"//& + "correction for the atmospheric (and sea-ice) pressure \n"//& + "limited by max_p_surf instead of the full atmospheric \n"//& + "pressure.", default=.true.) + +! smg: should get_param call should be removed when have A=B code reconciled. +! this param is used to distinguish how to diagnose surface heat content from water. + call get_param(param_file, mdl, "BULKMIXEDLAYER", CS%bulkmixedlayer, & + default=CS%use_temperature,do_not_log=.true.) + + call get_param(param_file, mdl, "WIND_STAGGER", stagger, & + "A case-insensitive character string to indicate the \n"//& + "staggering of the input wind stress field. Valid \n"//& + "values are 'A', 'B', or 'C'.", default="C") + if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID + elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE + elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE + else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & + trim(stagger)//" is invalid.") ; endif + call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & + "A factor multiplying the wind-stress given to the ocean by the\n"//& + "coupler. This is used for testing and should be =1.0 for any\n"//& + "production runs.", default=1.0) + + if (restore_salt) then + call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + "The constant that relates the restoring surface fluxes \n"//& + "to the relative surface anomalies (akin to a piston \n"//& + "velocity). Note the non-MKS units.", units="m day-1", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & + "A file in which to find the surface salinity to use for restoring.", & + default="salt_restore.nc") + call get_param(param_file, mdl, "SALT_RESTORE_VARIABLE", CS%salt_restore_var_name, & + "The name of the surface salinity variable to read from "//& + "SALT_RESTORE_FILE for restoring salinity.", & + default="salt") +! Convert CS%Flux_const from m day-1 to m s-1. + CS%Flux_const = CS%Flux_const / 86400.0 + + call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & + "If true, the restoring of salinity is applied as a salt \n"//& + "flux instead of as a freshwater flux.", default=.false.) + call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & + "The maximum salinity difference used in restoring terms.", & + units="PSU or g kg-1", default=999.0) + call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & + CS%mask_srestore_under_ice, & + "If true, disables SSS restoring under sea-ice based on a frazil\n"//& + "criteria (SST<=Tf). Only used when RESTORE_SALINITY is True.", & + default=.false.) + call get_param(param_file, mdl, "MASK_SRESTORE_MARGINAL_SEAS", & + CS%mask_srestore_marginal_seas, & + "If true, disable SSS restoring in marginal seas. Only used when\n"//& + "RESTORE_SALINITY is True.", default=.false.) + call get_param(param_file, mdl, "BASIN_FILE", basin_file, & + "A file in which to find the basin masks, in variable 'basin'.", & + default="basin.nc") + basin_file = trim(CS%inputdir) // trim(basin_file) + call safe_alloc_ptr(CS%basin_mask,isd,ied,jsd,jed) ; CS%basin_mask(:,:) = 1.0 + if (CS%mask_srestore_marginal_seas) then + call read_data(basin_file,'basin',CS%basin_mask,domain=G%domain%mpp_domain,timelevel=1) + do j=jsd,jed ; do i=isd,ied + if (CS%basin_mask(i,j) >= 6.0) then ; CS%basin_mask(i,j) = 0.0 + else ; CS%basin_mask(i,j) = 1.0 ; endif + enddo ; enddo + endif + endif + + if (restore_temp) then + call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + "The constant that relates the restoring surface fluxes \n"//& + "to the relative surface anomalies (akin to a piston \n"//& + "velocity). Note the non-MKS units.", units="m day-1", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & + "A file in which to find the surface temperature to use for restoring.", & + default="temp_restore.nc") + call get_param(param_file, mdl, "SST_RESTORE_VARIABLE", CS%temp_restore_var_name, & + "The name of the surface temperature variable to read from "//& + "SST_RESTORE_FILE for restoring sst.", & + default="temp") +! Convert CS%Flux_const from m day-1 to m s-1. + CS%Flux_const = CS%Flux_const / 86400.0 + + call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & + "The maximum sst difference used in restoring terms.", & + units="degC ", default=999.0) + + endif + +! Optionally read tidal amplitude from input file (m s-1) on model grid. +! Otherwise use default tidal amplitude for bottom frictionally-generated +! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of +! work done against tides globally using OSU tidal amplitude. + call get_param(param_file, mdl, "CD_TIDES", CS%cd_tides, & + "The drag coefficient that applies to the tides.", & + units="nondim", default=1.0e-4) + call get_param(param_file, mdl, "READ_TIDEAMP", CS%read_TIDEAMP, & + "If true, read a file (given by TIDEAMP_FILE) containing \n"//& + "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) + if (CS%read_TIDEAMP) then + call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & + "The path to the file containing the spatially varying \n"//& + "tidal amplitudes with INT_TIDE_DISSIPATION.", & + default="tideamp.nc") + CS%utide=0.0 + else + call get_param(param_file, mdl, "UTIDE", CS%utide, & + "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & + units="m s-1", default=0.0) + endif + + call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) + call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) + + if (CS%read_TIDEAMP) then + TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) + call read_data(TideAmp_file,'tideamp',CS%TKE_tidal,domain=G%domain%mpp_domain,timelevel=1) + do j=jsd, jed; do i=isd, ied + utide = CS%TKE_tidal(i,j) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%ustar_tidal(i,j)=sqrt(CS%cd_tides)*utide + enddo ; enddo + else + do j=jsd,jed; do i=isd,ied + utide=CS%utide + CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%ustar_tidal(i,j)=sqrt(CS%cd_tides)*utide + enddo ; enddo + endif + + call time_interp_external_init + +! Optionally read a x-y gustiness field in place of a global +! constant. + + call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & + "If true, use a 2-dimensional gustiness supplied from \n"//& + "an input file", default=.false.) + call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & + "The background gustiness in the winds.", units="Pa", & + default=0.02) + if (CS%read_gust_2d) then + call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & + "The file in which the wind gustiness is found in \n"//& + "variable gustiness.") + + call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) + gust_file = trim(CS%inputdir) // trim(gust_file) + call read_data(gust_file,'gustiness',CS%gust,domain=G%domain%mpp_domain, & + timelevel=1) ! units should be Pa + endif + +! See whether sufficiently thick sea ice should be treated as rigid. + call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & + "If true, sea-ice is rigid enough to exert a \n"//& + "nonhydrostatic pressure that resist vertical motion.", & + default=.false.) + if (CS%rigid_sea_ice) then + call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & + "A typical density of sea ice, used with the kinematic \n"//& + "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & + default=900.0) + call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & + "The kinematic viscosity of sufficiently thick sea ice \n"//& + "for use in calculating the rigidity of sea ice.", & + units="m2 s-1", default=1.0e9) + call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & + "The mass of sea-ice per unit area at which the sea-ice \n"//& + "starts to exhibit rigidity", units="kg m-2", default=1000.0) + endif + + call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & + "If true, makes available diagnostics of fluxes from icebergs\n"//& + "as seen by MOM6.", default=.false.) + call register_forcing_type_diags(Time, diag, CS%use_temperature, CS%handles, & + use_berg_fluxes=iceberg_flux_diags) + + call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & + "If true, allows flux adjustments to specified via the \n"//& + "data_table using the component name 'OCN'.", default=.false.) + if (CS%allow_flux_adjustments) then + call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) + endif + + if (present(restore_salt)) then ; if (restore_salt) then + salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) + CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) + endif ; endif + + if (present(restore_temp)) then ; if (restore_temp) then + temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) + CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) + endif ; endif + + ! Set up any restart fields associated with the forcing. + call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") +!### call register_ctrl_forcing_restarts(G, param_file, CS%ctrl_forcing_CSp, & +!### CS%restart_CSp) + call restart_init_end(CS%restart_CSp) + + if (associated(CS%restart_CSp)) then + call Get_MOM_Input(dirs=dirs) + + new_sim = .false. + if ((dirs%input_filename(1:1) == 'n') .and. & + (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. + if (.not.new_sim) then + call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & + G, CS%restart_CSp) + endif + endif + +!### call controlled_forcing_init(Time, G, param_file, diag, CS%ctrl_forcing_CSp) + + call user_revise_forcing_init(param_file, CS%urf_CS) + + call cpu_clock_end(id_clock_forcing) +end subroutine surface_forcing_init + +!======================================================================= + +!> Finalizes surface forcing: deallocate surface forcing control structure +subroutine surface_forcing_end(CS, fluxes) + type(surface_forcing_CS), pointer :: CS + type(forcing), optional, intent(inout) :: fluxes +! Arguments: CS - A pointer to the control structure returned by a previous +! call to surface_forcing_init, it will be deallocated here. +! (inout) fluxes - A structure containing pointers to any possible +! forcing fields. Unused fields have NULL ptrs. + + if (present(fluxes)) call deallocate_forcing_type(fluxes) + +!### call controlled_forcing_end(CS%ctrl_forcing_CSp) + + if (associated(CS)) deallocate(CS) + CS => NULL() + +end subroutine surface_forcing_end + +!======================================================================= + +subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) + + character(len=*), intent(in) :: id + integer , intent(in) :: timestep + type(ice_ocean_boundary_type), intent(in) :: iobt + integer :: n,m, outunit + + outunit = stdout() + + write(outunit,*) "BEGIN CHECKSUM(ice_ocean_boundary_type):: ", id, timestep + write(outunit,100) 'iobt%u_flux ', mpp_chksum( iobt%u_flux ) + write(outunit,100) 'iobt%v_flux ', mpp_chksum( iobt%v_flux ) + write(outunit,100) 'iobt%t_flux ', mpp_chksum( iobt%t_flux ) + write(outunit,100) 'iobt%q_flux ', mpp_chksum( iobt%q_flux ) + write(outunit,100) 'iobt%salt_flux ', mpp_chksum( iobt%salt_flux ) + write(outunit,100) 'iobt%lw_flux ', mpp_chksum( iobt%lw_flux ) + write(outunit,100) 'iobt%sw_flux_vis_dir', mpp_chksum( iobt%sw_flux_vis_dir) + write(outunit,100) 'iobt%sw_flux_vis_dif', mpp_chksum( iobt%sw_flux_vis_dif) + write(outunit,100) 'iobt%sw_flux_nir_dir', mpp_chksum( iobt%sw_flux_nir_dir) + write(outunit,100) 'iobt%sw_flux_nir_dif', mpp_chksum( iobt%sw_flux_nir_dif) + write(outunit,100) 'iobt%lprec ', mpp_chksum( iobt%lprec ) + write(outunit,100) 'iobt%fprec ', mpp_chksum( iobt%fprec ) + write(outunit,100) 'iobt%runoff ', mpp_chksum( iobt%runoff ) + write(outunit,100) 'iobt%calving ', mpp_chksum( iobt%calving ) + write(outunit,100) 'iobt%p ', mpp_chksum( iobt%p ) + if (associated(iobt%ustar_berg)) & + write(outunit,100) 'iobt%ustar_berg ', mpp_chksum( iobt%ustar_berg ) + if (associated(iobt%area_berg)) & + write(outunit,100) 'iobt%area_berg ', mpp_chksum( iobt%area_berg ) + if (associated(iobt%mass_berg)) & + write(outunit,100) 'iobt%mass_berg ', mpp_chksum( iobt%mass_berg ) +100 FORMAT(" CHECKSUM::",A20," = ",Z20) + + call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') + +end subroutine ice_ocn_bnd_type_chksum + +end module MOM_surface_forcing diff --git a/config_src/mct_driver/ocn_cap_methods.F90 b/config_src/mct_driver/ocn_cap_methods.F90 new file mode 100644 index 0000000000..cc214306f0 --- /dev/null +++ b/config_src/mct_driver/ocn_cap_methods.F90 @@ -0,0 +1,239 @@ +module ocn_cap_methods + + use ESMF, only: ESMF_clock, ESMF_time, ESMF_ClockGet, ESMF_TimeGet + use MOM_ocean_model, only: ocean_public_type, ocean_state_type + use MOM_surface_forcing, only: ice_ocean_boundary_type + use MOM_grid, only: ocean_grid_type + use MOM_domains, only: pass_var + use MOM_error_handler, only: is_root_pe + use mpp_domains_mod, only: mpp_get_compute_domain + use ocn_cpl_indices, only: cpl_indices_type + + implicit none + private + + public :: ocn_import + public :: ocn_export + + logical, parameter :: debug=.false. + +!======================================================================= +contains +!======================================================================= + + !> Maps incomping ocean data to MOM6 data structures + subroutine ocn_import(x2o, ind, grid, ice_ocean_boundary, ocean_public, logunit, Eclock, c1, c2, c3, c4) + real(kind=8) , intent(in) :: x2o(:,:) !< incoming data + type(cpl_indices_type) , intent(in) :: ind !< Structure with MCT attribute vects and indices + type(ocean_grid_type) , intent(in) :: grid !< Ocean model grid + type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing + type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state + integer , intent(in) :: logunit !< Unit for stdout output + type(ESMF_Clock) , intent(in) :: EClock !< Time and time step ? \todo Why must this + real(kind=8), optional , intent(in) :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition + + ! Local variables + integer :: i, j, ig, jg, isc, iec, jsc, jec ! Grid indices + integer :: k + integer :: day, secs, rc + type(ESMF_time) :: currTime + character(*), parameter :: F01 = "('(ocn_import) ',a,4(i6,2x),d21.14)" + !----------------------------------------------------------------------- + + isc = GRID%isc; iec = GRID%iec ; jsc = GRID%jsc; jec = GRID%jec + + k = 0 + do j = jsc, jec + jg = j + grid%jsc - jsc + do i = isc, iec + ig = i + grid%jsc - isc + k = k + 1 ! Increment position within gindex + + ! taux + ice_ocean_boundary%u_flux(i,j) = x2o(ind%x2o_Foxx_taux,k) + + ! tauy + ice_ocean_boundary%v_flux(i,j) = x2o(ind%x2o_Foxx_tauy,k) + + ! liquid precipitation (rain) + ice_ocean_boundary%lprec(i,j) = x2o(ind%x2o_Faxa_rain,k) + + ! frozen precipitation (snow) + ice_ocean_boundary%fprec(i,j) = x2o(ind%x2o_Faxa_snow,k) + + ! longwave radiation, sum up and down (W/m2) + ice_ocean_boundary%lw_flux(i,j) = (x2o(ind%x2o_Faxa_lwdn,k) + x2o(ind%x2o_Foxx_lwup,k)) + + ! specific humitidy flux + ice_ocean_boundary%q_flux(i,j) = x2o(ind%x2o_Foxx_evap,k) !???TODO: should this be a minus sign + + ! sensible heat flux (W/m2) + ice_ocean_boundary%t_flux(i,j) = x2o(ind%x2o_Foxx_sen,k) !???TODO: should this be a minus sign + + ! latent heat flux (W/m^2) + ice_ocean_boundary%latent_flux(i,j) = x2o(ind%x2o_Foxx_lat,k) !???TODO: should this be a minus sign + + ! liquid runoff + ice_ocean_boundary%rofl_flux(i,j) = x2o(ind%x2o_Foxx_rofl,k) * GRID%mask2dT(ig,jg) + + ! ice runoff + ice_ocean_boundary%rofi_flux(i,j) = x2o(ind%x2o_Foxx_rofi,k) * GRID%mask2dT(ig,jg) + + ! surface pressure + ice_ocean_boundary%p(i,j) = x2o(ind%x2o_Sa_pslv,k) * GRID%mask2dT(ig,jg) + + ! salt flux + ice_ocean_boundary%salt_flux(i,j) = x2o(ind%x2o_Fioi_salt,k) * GRID%mask2dT(ig,jg) + + ! 1) visible, direct shortwave (W/m2) + ! 2) visible, diffuse shortwave (W/m2) + ! 3) near-IR, direct shortwave (W/m2) + ! 4) near-IR, diffuse shortwave (W/m2) + if (present(c1) .and. present(c2) .and. present(c3) .and. present(c4)) then + ! Use runtime coefficients to decompose net short-wave heat flux into 4 components + ice_ocean_boundary%sw_flux_vis_dir(i,j) = x2o(ind%x2o_Foxx_swnet,k) * c1 * GRID%mask2dT(ig,jg) + ice_ocean_boundary%sw_flux_vis_dif(i,j) = x2o(ind%x2o_Foxx_swnet,k) * c2 * GRID%mask2dT(ig,jg) + ice_ocean_boundary%sw_flux_nir_dir(i,j) = x2o(ind%x2o_Foxx_swnet,k) * c3 * GRID%mask2dT(ig,jg) + ice_ocean_boundary%sw_flux_nir_dif(i,j) = x2o(ind%x2o_Foxx_swnet,k) * c4 * GRID%mask2dT(ig,jg) + else + ice_ocean_boundary%sw_flux_vis_dir(i,j) = x2o(ind%x2o_Faxa_swvdr,k) * GRID%mask2dT(ig,jg) + ice_ocean_boundary%sw_flux_vis_dif(i,j) = x2o(ind%x2o_Faxa_swvdf,k) * GRID%mask2dT(ig,jg) + ice_ocean_boundary%sw_flux_nir_dir(i,j) = x2o(ind%x2o_Faxa_swndr,k) * GRID%mask2dT(ig,jg) + ice_ocean_boundary%sw_flux_nir_dif(i,j) = x2o(ind%x2o_Faxa_swndf,k) * GRID%mask2dT(ig,jg) + end if + end do + end do + + if (debug .and. is_root_pe()) then + call ESMF_ClockGet(EClock, CurrTime=CurrTime, rc=rc) + call ESMF_TimeGet(CurrTime, d=day, s=secs, rc=rc) + + do j = GRID%jsc, GRID%jec + do i = GRID%isc, GRID%iec + write(logunit,F01)'import: day, secs, j, i, u_flux = ',day,secs,j,i,ice_ocean_boundary%u_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, v_flux = ',day,secs,j,i,ice_ocean_boundary%v_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, lprec = ',day,secs,j,i,ice_ocean_boundary%lprec(i,j) + write(logunit,F01)'import: day, secs, j, i, lwrad = ',day,secs,j,i,ice_ocean_boundary%lw_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, q_flux = ',day,secs,j,i,ice_ocean_boundary%q_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, t_flux = ',day,secs,j,i,ice_ocean_boundary%t_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, latent_flux = ',& + day,secs,j,i,ice_ocean_boundary%latent_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, runoff = ',& + day,secs,j,i,ice_ocean_boundary%rofl_flux(i,j) + ice_ocean_boundary%rofi_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, psurf = ',& + day,secs,j,i,ice_ocean_boundary%p(i,j) + write(logunit,F01)'import: day, secs, j, i, salt_flux = ',& + day,secs,j,i,ice_ocean_boundary%salt_flux(i,j) + write(logunit,F01)'import: day, secs, j, i, sw_flux_vis_dir = ',& + day,secs,j,i,ice_ocean_boundary%sw_flux_vis_dir(i,j) + write(logunit,F01)'import: day, secs, j, i, sw_flux_vis_dif = ',& + day,secs,j,i,ice_ocean_boundary%sw_flux_vis_dif(i,j) + write(logunit,F01)'import: day, secs, j, i, sw_flux_nir_dir = ',& + day,secs,j,i,ice_ocean_boundary%sw_flux_nir_dir(i,j) + write(logunit,F01)'import: day, secs, j, i, sw_flux_nir_dif = ',& + day,secs,j,i,ice_ocean_boundary%sw_flux_nir_dir(i,j) + end do + end do + end if + + end subroutine ocn_import + +!======================================================================= + + !> Maps outgoing ocean data to MCT attribute vector real array + subroutine ocn_export(ind, ocn_public, grid, o2x) + type(cpl_indices_type), intent(inout) :: ind !< Structure with coupler indices and vectors + type(ocean_public_type), intent(in) :: ocn_public !< Ocean surface state + type(ocean_grid_type), intent(in) :: grid !< Ocean model grid + real(kind=8), intent(inout) :: o2x(:,:) !< MCT outgoing bugger + + ! Local variables + real, dimension(grid%isd:grid%ied,grid%jsd:grid%jed) :: ssh !< Local copy of sea_lev with updated halo + integer :: i, j, n, ig, jg !< Grid indices + real :: slp_L, slp_R, slp_C, slope, u_min, u_max + !----------------------------------------------------------------------- + + ! Copy from ocn_public to o2x. ocn_public uses global indexing with no halos. + ! The mask comes from "grid" that uses the usual MOM domain that has halos + ! and does not use global indexing. + + n = 0 + do j=grid%jsc, grid%jec + jg = j + grid%jdg_offset + do i=grid%isc,grid%iec + n = n+1 + ig = i + grid%idg_offset + ! surface temperature in Kelvin + o2x(ind%o2x_So_t, n) = ocn_public%t_surf(ig,jg) * grid%mask2dT(i,j) + o2x(ind%o2x_So_s, n) = ocn_public%s_surf(ig,jg) * grid%mask2dT(i,j) + o2x(ind%o2x_So_u, n) = ocn_public%u_surf(ig,jg) * grid%mask2dT(i,j) + o2x(ind%o2x_So_v, n) = ocn_public%v_surf(ig,jg) * grid%mask2dT(i,j) + ! Make a copy of ssh in order to do a halo update. We use the usual MOM domain + ! in order to update halos. i.e. does not use global indexing. + ssh(i,j) = ocn_public%sea_lev(ig,jg) + end do + end do + + ! Update halo of ssh so we can calculate gradients + call pass_var(ssh, grid%domain) + + ! d/dx ssh + n = 0 + do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec + n = n+1 + ! This is a simple second-order difference + ! o2x(ind%o2x_So_dhdx, n) = 0.5 * (ssh(i+1,j) - ssh(i-1,j)) * grid%IdxT(i,j) * grid%mask2dT(i,j) + ! This is a PLM slope which might be less prone to the A-grid null mode + slp_L = (ssh(I,j) - ssh(I-1,j)) * grid%mask2dCu(I-1,j) + if (grid%mask2dCu(I-1,j)==0.) slp_L = 0. + slp_R = (ssh(I+1,j) - ssh(I,j)) * grid%mask2dCu(I,j) + if (grid%mask2dCu(I+1,j)==0.) slp_R = 0. + slp_C = 0.5 * (slp_L + slp_R) + if ( (slp_L * slp_R) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + u_min = min( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) + u_max = max( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) + slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + slope = 0.0 + end if + o2x(ind%o2x_So_dhdx, n) = slope * grid%IdxT(i,j) * grid%mask2dT(i,j) + if (grid%mask2dT(i,j)==0.) o2x(ind%o2x_So_dhdx, n) = 0.0 + end do; end do + + ! d/dy ssh + n = 0 + do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec + n = n+1 + ! This is a simple second-order difference + ! o2x(ind%o2x_So_dhdy, n) = 0.5 * (ssh(i,j+1) - ssh(i,j-1)) * grid%IdyT(i,j) * grid%mask2dT(i,j) + ! This is a PLM slope which might be less prone to the A-grid null mode + slp_L = ssh(i,J) - ssh(i,J-1) * grid%mask2dCv(i,J-1) + if (grid%mask2dCv(i,J-1)==0.) slp_L = 0. + + slp_R = ssh(i,J+1) - ssh(i,J) * grid%mask2dCv(i,J) + if (grid%mask2dCv(i,J+1)==0.) slp_R = 0. + + slp_C = 0.5 * (slp_L + slp_R) + !write(6,*)'slp_L, slp_R,i,j,slp_L*slp_R', slp_L, slp_R,i,j,slp_L*slp_R + if ((slp_L * slp_R) > 0.0) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + u_min = min( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) + u_max = max( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) + slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + slope = 0.0 + end if + o2x(ind%o2x_So_dhdy, n) = slope * grid%IdyT(i,j) * grid%mask2dT(i,j) + if (grid%mask2dT(i,j)==0.) o2x(ind%o2x_So_dhdy, n) = 0.0 + end do; end do + + end subroutine ocn_export + +end module ocn_cap_methods diff --git a/config_src/mct_driver/ocn_comp_mct.F90 b/config_src/mct_driver/ocn_comp_mct.F90 index a24dd03fd9..63a24b153d 100644 --- a/config_src/mct_driver/ocn_comp_mct.F90 +++ b/config_src/mct_driver/ocn_comp_mct.F90 @@ -4,84 +4,61 @@ module ocn_comp_mct ! This file is part of MOM6. See LICENSE.md for the license. ! mct modules -use ESMF, only: ESMF_clock, ESMF_time, ESMF_timeInterval, ESMF_TimeInc +use ESMF, only: ESMF_clock, ESMF_time, ESMF_timeInterval use ESMF, only: ESMF_ClockGet, ESMF_TimeGet, ESMF_TimeIntervalGet use seq_cdata_mod, only: seq_cdata, seq_cdata_setptrs -use seq_flds_mod, only: ice_ncat, seq_flds_i2o_per_cat +use seq_flds_mod, only: seq_flds_x2o_fields, seq_flds_o2x_fields use mct_mod, only: mct_gsMap, mct_gsmap_init, mct_gsMap_lsize, & mct_gsmap_orderedpoints use mct_mod, only: mct_aVect, mct_aVect_init, mct_aVect_zero, & mct_aVect_nRattr use mct_mod, only: mct_gGrid, mct_gGrid_init, mct_gGrid_importRAttr, & mct_gGrid_importIAttr -use mct_mod, only: mct_avect_indexra, mct_aVect_clean -use seq_flds_mod, only: seq_flds_x2o_fields, seq_flds_o2x_fields, seq_flds_dom_coord, & - seq_flds_dom_other use seq_infodata_mod, only: seq_infodata_type, seq_infodata_GetData, & seq_infodata_start_type_start, seq_infodata_start_type_cont, & seq_infodata_start_type_brnch, seq_infodata_PutData use seq_comm_mct, only: seq_comm_name, seq_comm_inst, seq_comm_suffix use seq_timemgr_mod, only: seq_timemgr_EClockGetData, seq_timemgr_RestartAlarmIsOn use perf_mod, only: t_startf, t_stopf -use shr_kind_mod, only: shr_kind_r8 use shr_file_mod, only: shr_file_getUnit, shr_file_freeUnit, shr_file_setIO, & shr_file_getLogUnit, shr_file_getLogLevel, & shr_file_setLogUnit, shr_file_setLogLevel +use MOM_surface_forcing, only: IOB_allocate, ice_ocean_boundary_type + ! MOM6 modules -use MOM_domains, only : MOM_infra_init, MOM_infra_end -use MOM_coms, only : reproducing_sum -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_SUBCOMPONENT -use MOM, only: initialize_MOM, step_MOM, MOM_control_struct, MOM_end -use MOM, only: extract_surface_state, allocate_surface_state -use MOM, only: finish_MOM_initialization, step_offline -use MOM, only: get_MOM_state_elements, MOM_state_is_synchronized -use MOM_forcing_type, only: forcing, forcing_diags, register_forcing_type_diags -use MOM_forcing_type, only: allocate_forcing_type, deallocate_forcing_type -use MOM_forcing_type, only: mech_forcing_diags, forcing_accumulate, forcing_diagnostics -use MOM_forcing_type, only: mech_forcing, allocate_mech_forcing, copy_back_forcing_fields -use MOM_forcing_type, only: set_net_mass_forcing, set_derived_forcing_fields -use MOM_forcing_type, only: copy_common_forcing_fields +use MOM, only: extract_surface_state +use MOM_variables, only: surface +use MOM_domains, only: MOM_infra_init use MOM_restart, only: save_restart +use MOM_ice_shelf, only: ice_shelf_save_restart use MOM_domains, only: num_pes, root_pe, pe_here -use MOM_domains, only: pass_vector, BGRID_NE, CGRID_NE, To_All -use MOM_domains, only: pass_var, AGRID, fill_symmetric_edges use MOM_grid, only: ocean_grid_type, get_global_grid_size -use MOM_verticalGrid, only: verticalGrid_type -use MOM_variables, only: surface use MOM_error_handler, only: MOM_error, FATAL, is_root_pe, WARNING -use MOM_error_handler, only: callTree_enter, callTree_leave -use MOM_time_manager, only: time_type, set_date, set_time, set_calendar_type, NOLEAP, get_date +use MOM_time_manager, only: time_type, set_date, set_time, set_calendar_type, NOLEAP use MOM_time_manager, only: operator(+), operator(-), operator(*), operator(/) use MOM_time_manager, only: operator(==), operator(/=), operator(>), get_time -use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file +use MOM_file_parser, only: get_param, log_version, param_file_type use MOM_get_input, only: Get_MOM_Input, directories -use MOM_diag_mediator, only: diag_ctrl, enable_averaging, disable_averaging -use MOM_diag_mediator, only: diag_mediator_close_registration, diag_mediator_end -use MOM_diag_mediator, only: safe_alloc_ptr -use MOM_ice_shelf, only: initialize_ice_shelf, shelf_calc_flux, ice_shelf_CS -use MOM_ice_shelf, only: ice_shelf_end, ice_shelf_save_restart -use MOM_string_functions, only: uppercase -use MOM_constants, only: CELSIUS_KELVIN_OFFSET, hlf, hlv use MOM_EOS, only: gsw_sp_from_sr, gsw_pt_from_ct -use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init -use user_revise_forcing, only : user_revise_forcing_CS -use MOM_restart, only : restart_init, MOM_restart_CS -use MOM_restart, only : restart_init_end, save_restart, restore_state -use data_override_mod, only : data_override_init, data_override -use MOM_io, only : slasher, write_version_number -use MOM_spatial_means, only : adjust_area_mean_to_zero +use MOM_constants, only: CELSIUS_KELVIN_OFFSET +use MOM_domains, only: AGRID, BGRID_NE, CGRID_NE, pass_vector +use mpp_domains_mod, only: mpp_get_compute_domain + +! Previously inlined - now in separate modules +use MOM_ocean_model, only: ocean_public_type, ocean_state_type +use MOM_ocean_model, only: ocean_model_init , update_ocean_model, ocean_model_end +use MOM_ocean_model, only: convert_state_to_ocean_type +use MOM_surface_forcing, only: surface_forcing_CS, forcing_save_restart +use ocn_cap_methods, only: ocn_import, ocn_export ! FMS modules -use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain -use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain -use time_interp_external_mod, only : init_external_field, time_interp_external -use time_interp_external_mod, only : time_interp_external_init -use fms_mod, only : read_data +use time_interp_external_mod, only : time_interp_external + +! MCT indices structure and import and export routines that access mom data +use ocn_cpl_indices, only : cpl_indices_type, cpl_indices_init ! GFDL coupler modules -use coupler_types_mod, only : coupler_1d_bc_type, coupler_2d_bc_type use coupler_types_mod, only : coupler_type_spawn use coupler_types_mod, only : coupler_type_initialized, coupler_type_copy_data @@ -94,283 +71,36 @@ module ocn_comp_mct public :: ocn_init_mct public :: ocn_run_mct public :: ocn_final_mct + +! Private member functions +private :: ocn_SetGSMap_mct +private :: ocn_domain_mct +private :: get_runtype +private :: ocean_model_init_sfc + ! Flag for debugging logical, parameter :: debug=.true. -!> Structure with MCT attribute vectors and indices -type cpl_indices - - ! ocean to coupler - integer :: o2x_So_t !< Surface potential temperature (deg C) - integer :: o2x_So_u !< Surface zonal velocity (m/s) - integer :: o2x_So_v !< Surface meridional velocity (m/s) - integer :: o2x_So_s !< Surface salinity (PSU) - integer :: o2x_So_dhdx !< Zonal slope in the sea surface height - integer :: o2x_So_dhdy !< Meridional lope in the sea surface height - integer :: o2x_So_bldepth !< Boundary layer depth (m) - integer :: o2x_Fioo_q !< Heat flux? - integer :: o2x_Faoo_fco2_ocn!< CO2 flux - integer :: o2x_Faoo_fdms_ocn!< DMS flux - - ! coupler to ocean - integer :: x2o_Si_ifrac !< Fractional ice wrt ocean - integer :: x2o_So_duu10n !< 10m wind speed squared (m^2/s^2) - integer :: x2o_Sa_pslv !< Sea-level pressure (Pa) - integer :: x2o_Sa_co2prog !< Bottom atm level prognostic CO2 - integer :: x2o_Sa_co2diag !< Bottom atm level diagnostic CO2 - integer :: x2o_Sw_lamult !< Wave model langmuir multiplier - integer :: x2o_Sw_ustokes !< Surface Stokes drift, x-component - integer :: x2o_Sw_vstokes !< Surface Stokes drift, y-component - integer :: x2o_Foxx_taux !< Zonal wind stress (W/m2) - integer :: x2o_Foxx_tauy !< Meridonal wind stress (W/m2) - integer :: x2o_Foxx_swnet !< Net short-wave heat flux (W/m2) - integer :: x2o_Foxx_sen !< Sensible heat flux (W/m2) - integer :: x2o_Foxx_lat !< Latent heat flux (W/m2) - integer :: x2o_Foxx_lwup !< Longwave radiation, up (W/m2) - integer :: x2o_Faxa_lwdn !< Longwave radiation, down (W/m2) - integer :: x2o_Fioi_melth !< Heat flux from snow & ice melt (W/m2) - integer :: x2o_Fioi_meltw !< Snow melt flux (kg/m2/s) - integer :: x2o_Fioi_bcpho !< Black Carbon hydrophobic release - !! from sea ice component - integer :: x2o_Fioi_bcphi !< Black Carbon hydrophilic release from - !! sea ice component - integer :: x2o_Fioi_flxdst !< Dust release from sea ice component - integer :: x2o_Fioi_salt !< Salt flux (kg(salt)/m2/s) - integer :: x2o_Foxx_evap !< Evaporation flux (kg/m2/s) - integer :: x2o_Faxa_prec !< Total precipitation flux (kg/m2/s) - integer :: x2o_Faxa_snow !< Water flux due to snow (kg/m2/s) - integer :: x2o_Faxa_rain !< Water flux due to rain (kg/m2/s) - integer :: x2o_Faxa_bcphidry !< Black Carbon hydrophilic dry deposition - integer :: x2o_Faxa_bcphodry !< Black Carbon hydrophobic dry deposition - integer :: x2o_Faxa_bcphiwet !< Black Carbon hydrophilic wet deposition - integer :: x2o_Faxa_ocphidry !< Organic Carbon hydrophilic dry deposition - integer :: x2o_Faxa_ocphodry !< Organic Carbon hydrophobic dry deposition - integer :: x2o_Faxa_ocphiwet !< Organic Carbon hydrophilic dry deposition - integer :: x2o_Faxa_dstwet1 !< Size 1 dust -- wet deposition - integer :: x2o_Faxa_dstwet2 !< Size 2 dust -- wet deposition - integer :: x2o_Faxa_dstwet3 !< Size 3 dust -- wet deposition - integer :: x2o_Faxa_dstwet4 !< Size 4 dust -- wet deposition - integer :: x2o_Faxa_dstdry1 !< Size 1 dust -- dry deposition - integer :: x2o_Faxa_dstdry2 !< Size 2 dust -- dry deposition - integer :: x2o_Faxa_dstdry3 !< Size 3 dust -- dry deposition - integer :: x2o_Faxa_dstdry4 !< Size 4 dust -- dry deposition - integer :: x2o_Foxx_rofl !< River runoff flux (kg/m2/s) - integer :: x2o_Foxx_rofi !< Ice runoff flux (kg/m2/s) - - ! optional per thickness category fields - integer, dimension(:), allocatable :: x2o_frac_col !< Fraction of ocean cell, - !! per column - integer, dimension(:), allocatable :: x2o_fracr_col!< Fraction of ocean cell used - !! in radiation computations, - !! per column - integer, dimension(:), allocatable :: x2o_qsw_fracr_col !< qsw * fracr, per column -end type cpl_indices - -!> This type is used for communication with other components via the FMS coupler. -! The element names and types can be changed only with great deliberation, hence -! the persistnce of things like the cutsy element name "avg_kount". -type, public :: ocean_public_type - type(domain2d) :: Domain !< The domain for the surface fields. - logical :: is_ocean_pe !! .true. on processors that run the ocean model. - character(len=32) :: instance_name = '' !< A name that can be used to identify - !! this instance of an ocean model, for example - !! in ensembles when writing messages. - integer, pointer, dimension(:) :: pelist => NULL() !< The list of ocean PEs. - logical, pointer, dimension(:,:) :: maskmap =>NULL() !< A pointer to an array - !! indicating which logical processors are actually - !! used for the ocean code. The other logical - !! processors would be all land points and are not - !! assigned to actual processors. This need not be - !! assigned if all logical processors are used. - - integer :: stagger = -999 !< The staggering relative to the tracer points - !! of the two velocity components. Valid entries - !! include AGRID, BGRID_NE, CGRID_NE, BGRID_SW, and CGRID_SW, - !! corresponding to the community-standard Arakawa notation. - !! (These are named integers taken from mpp_parameter_mod.) - !! Following MOM, this is BGRID_NE by default when the ocean - !! is initialized, but here it is set to -999 so that a - !! global max across ocean and non-ocean processors can be - !! used to determine its value. - real, pointer, dimension(:,:) :: & - t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) - s_surf => NULL(), & !< SSS on t-cell (psu) - u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. - v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. - sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, - !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) - frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil - !! formation in the ocean. - area => NULL() !< cell area of the ocean surface, in m2. - type(coupler_2d_bc_type) :: fields !< A structure that may contain an - !! array of named tracer-related fields. - integer :: avg_kount !< Used for accumulating averages of this type. - integer, dimension(2) :: axes = 0 !< Axis numbers that are available - ! for I/O using this surface data. -end type ocean_public_type - -!> Contains pointers to the forcing fields which may be used to drive MOM. -!! All fluxes are positive downward. -type, public :: surface_forcing_CS ; private - integer :: wind_stagger !< AGRID, BGRID_NE, or CGRID_NE (integer values - !! from MOM_domains) to indicate the staggering of - !! the winds that are being provided in calls to - !! update_ocean_model. CIME uses AGRID, so this option - !! is being hard coded for now. - logical :: use_temperature !< If true, temp and saln used as state variables - real :: wind_stress_multiplier!< A multiplier applied to incoming wind stress (nondim). - ! smg: remove when have A=B code reconciled - logical :: bulkmixedlayer !< If true, model based on bulk mixed layer code - real :: Rho0 !< Boussinesq reference density (kg/m^3) - real :: area_surf = -1.0 !< total ocean surface area (m^2) - real :: latent_heat_fusion !< latent heat of fusion (J/kg) - real :: latent_heat_vapor !< latent heat of vaporization (J/kg) - real :: max_p_surf !< maximum surface pressure that can be - !! exerted by the atmosphere and floating sea-ice, - !! in Pa. This is needed because the FMS coupling - !! structure does not limit the water that can be - !! frozen out of the ocean and the ice-ocean heat - !! fluxes are treated explicitly. - logical :: use_limited_P_SSH !< If true, return the sea surface height with - !! the correction for the atmospheric (and sea-ice) - !! pressure limited by max_p_surf instead of the - !! full atmospheric pressure. The default is true. - real :: gust_const !< constant unresolved background gustiness for ustar (Pa) - logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied - !! from an input file. - real, pointer, dimension(:,:) :: & - TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the - !! bottom boundary layer by drag on the tidal flows, - !! in W m-2. - gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar (Pa). - !! gust is used when read_gust_2d is true. - ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity (m/s) - real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) - real :: utide !< constant tidal velocity to use if read_tideamp - !! is false, in m s-1. - logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. - logical :: rigid_sea_ice !< If true, sea-ice exerts a rigidity that acts - !! to damp surface deflections (especially surface - !! gravity waves). The default is false. - real :: Kv_sea_ice !< viscosity in sea-ice that resists sheared vertical motions (m^2/s) - real :: density_sea_ice !< typical density of sea-ice (kg/m^3). The value is - !! only used to convert the ice pressure into - !! appropriate units for use with Kv_sea_ice. - real :: rigid_sea_ice_mass !< A mass per unit area of sea-ice beyond which - !! sea-ice viscosity becomes effective, in kg m-2, - !! typically of order 1000 kg m-2. - logical :: allow_flux_adjustments !< If true, use data_override to obtain flux adjustments - real :: Flux_const !< piston velocity for surface restoring (m/s) - logical :: salt_restore_as_sflux !< If true, SSS restore as salt flux instead of water flux - logical :: adjust_net_srestore_to_zero !< adjust srestore to zero (for both salt_flux or vprec) - logical :: adjust_net_srestore_by_scaling !< adjust srestore w/o moving zero contour - logical :: adjust_net_fresh_water_to_zero !< adjust net surface fresh-water (w/ restoring) to zero - logical :: adjust_net_fresh_water_by_scaling !< adjust net surface fresh-water w/o moving zero contour - logical :: mask_srestore_under_ice !< If true, use an ice mask defined by frazil - !! criteria for salinity restoring. - real :: ice_salt_concentration !< salt concentration for sea ice (kg/kg) - logical :: mask_srestore_marginal_seas !< if true, then mask SSS restoring in marginal seas - real :: max_delta_srestore !< maximum delta salinity used for restoring - real :: max_delta_trestore !< maximum delta sst used for restoring - real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring - type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing - character(len=200) :: inputdir !< directory where NetCDF input files are - character(len=200) :: salt_restore_file !< filename for salt restoring data - character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file - character(len=200) :: temp_restore_file !< filename for sst restoring data - character(len=30) :: temp_restore_var_name !< name of surface temperature in temp_restore_file - integer :: id_srestore = -1 !< id number for time_interp_external. - integer :: id_trestore = -1 !< id number for time_interp_external. - type(forcing_diags), public :: handles !< diagnostics handles - !### type(ctrl_forcing_CS), pointer :: ctrl_forcing_CSp => NULL() - type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< restart pointer - type(user_revise_forcing_CS), pointer :: urf_CS => NULL()!< user revise pointer -end type surface_forcing_CS - -!> Contains information about the ocean state, although it is not necessary that -!! this is implemented with all models. This type is private, and can therefore vary -!! between different ocean models. -type, public :: ocean_state_type ; private - logical :: is_ocean_PE = .false. !< True if this is an ocean PE. - type(time_type) :: Time !< The ocean model's time and master clock. - integer :: Restart_control !< An integer that is bit-tested to determine whether - !! incremental restart files are saved and whether they - !! have a time stamped name. +1 (bit 0) for generic - !! files and +2 (bit 1) for time-stamped files. A - !! restart file is saved at the end of a run segment - !! unless Restart_control is negative. - integer :: nstep = 0 !< The number of calls to update_ocean. - logical :: use_ice_shelf !< If true, the ice shelf model is enabled. - logical :: icebergs_apply_rigid_boundary !< If true, the icebergs can change ocean bd condition. - real :: kv_iceberg !< The viscosity of the icebergs in m2/s (for ice rigidity) - real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy - !! so that fluxes below are set to zero. (0.5 is a - !! good value to use. Not applied for negative values. - real :: latent_heat_fusion !< Latent heat of fusion - real :: density_iceberg !< A typical density of icebergs in kg/m3 (for ice rigidity) - type(ice_shelf_CS), pointer :: Ice_shelf_CSp => NULL() !< ice shelf structure. - logical :: restore_salinity !< If true, the coupled MOM driver adds a term to - !! restore salinity to a specified value. - logical :: restore_temp !< If true, the coupled MOM driver adds a term to - !! restore sst to a specified value. - real :: press_to_z !< A conversion factor between pressure and ocean - !! depth in m, usually 1/(rho_0*g), in m Pa-1. - real :: C_p !< The heat capacity of seawater, in J K-1 kg-1. - logical :: offline_tracer_mode = .false. !< If false, use the model in prognostic mode - !! with the barotropic and baroclinic dynamics, thermodynamics, - !! etc. stepped forward integrated in time. - !! If true, all of the above are bypassed with all - !! fields necessary to integrate only the tracer advection - !! and diffusion equation read in from files stored from - !! a previous integration of the prognostic model. - type(directories) :: dirs !< A structure containing several relevant directory paths. - type(mech_forcing) :: forces!< A structure with the driving mechanical surface forces - type(forcing) :: fluxes !< A structure containing pointers to - !! the ocean forcing fields. - type(forcing) :: flux_tmp !< A secondary structure containing pointers to the - !! ocean forcing fields for when multiple coupled - !! timesteps are taken per thermodynamic step. - type(surface) :: sfc_state !< A structure containing pointers to - !! the ocean surface state fields. - type(ocean_grid_type), pointer :: grid => NULL() !< A pointer to a grid structure - !! containing metrics and related information. - type(verticalGrid_type), pointer :: GV => NULL() !< A pointer to a vertical grid - !! structure containing metrics and related information. - type(MOM_control_struct), pointer :: MOM_CSp => NULL() - type(surface_forcing_CS), pointer :: forcing_CSp => NULL() - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set 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 -end type ocean_state_type - !> Control structure for this module type MCT_MOM_Data - - type(ocean_state_type), pointer :: ocn_state => NULL() !< The private state of ocean - type(ocean_public_type), pointer :: ocn_public => NULL() !< The public state of ocean - type(ocean_grid_type), pointer :: grid => NULL() !< The grid structure - type(surface), pointer :: ocn_surface => NULL() !< The ocean surface state - type(forcing) :: fluxes !< Structure that contains pointers to the - !! boundary forcing used to drive the liquid - !! ocean simulated by MOM. - type(seq_infodata_type), pointer :: infodata !< The input info type - type(cpl_indices), public :: ind !< Variable IDs - ! runtime params - logical :: sw_decomp !< Controls whether shortwave is decomposed into four components - real :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition - ! i/o - character(len=384) :: pointer_filename !< Name of the ascii file that contains the path - !! and filename of the latest restart file. - integer :: stdout !< standard output unit. (by default, it should point to ocn.log.* file) + type(ocean_state_type), pointer :: ocn_state => NULL() !< The private state of ocean + type(ocean_public_type), pointer :: ocn_public => NULL() !< The public state of ocean + type(ocean_grid_type), pointer :: grid => NULL() !< The grid structure + type(seq_infodata_type), pointer :: infodata !< The input info type + type(cpl_indices_type) :: ind !< Variable IDs + logical :: sw_decomp !< Controls whether shortwave is decomposed into 4 components + real :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition i/o + integer :: stdout !< standard output unit. (by default, points to ocn.log.* ) + character(len=384) :: pointer_filename !< Name of the ascii file that contains the path + !! and filename of the latest restart file. end type MCT_MOM_Data -type(MCT_MOM_Data) :: glb !< global structure -integer :: id_clock_forcing +type(MCT_MOM_Data) :: glb !< global structure +type(ice_ocean_boundary_type) :: ice_ocean_boundary +!======================================================================= contains +!======================================================================= !> This subroutine initializes MOM6. subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) @@ -382,24 +112,24 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) character(len=*), optional , intent(in) :: NLFilename !< Namelist filename ! local variables - type(time_type) :: time0 !< Model start time - type(ESMF_time) :: time_var !< ESMF_time variable to query time - type(ESMF_time) :: time_in_ESMF !< Initial time for ocean - type(ESMF_timeInterval) :: ocn_cpl_interval !< Ocean coupling interval - integer :: ncouple_per_day - integer :: year, month, day, hour, minute, seconds, seconds_n, seconds_d, rc - character(len=240) :: runid !< Run ID - character(len=32) :: runtype !< Run type - character(len=240) :: restartfile !< Path/Name of restart file - integer :: nu !< i/o unit to read pointer file - character(len=240) :: restart_pointer_file !< File name for restart pointer file - character(len=240) :: restartpath !< Path of the restart file - integer :: mpicom_ocn !< MPI ocn communicator - integer :: npes, pe0 !< # of processors and current processor - integer :: i, errorCode - integer :: lsize, nsend, nrecv - logical :: ldiag_cpl = .false. - integer :: isc, iec, jsc, jec, ni, nj !< Indices for the start and end of the domain + type(time_type) :: time0 !< Model start time + type(ESMF_time) :: time_var !< ESMF_time variable to query time + type(ESMF_time) :: time_in_ESMF !< Initial time for ocean + type(ESMF_timeInterval) :: ocn_cpl_interval !< Ocean coupling interval + integer :: ncouple_per_day + integer :: year, month, day, hour, minute, seconds, seconds_n, seconds_d, rc + character(len=240) :: runid !< Run ID + character(len=32) :: runtype !< Run type + character(len=240) :: restartfile !< Path/Name of restart file + integer :: nu !< i/o unit to read pointer file + character(len=240) :: restart_pointer_file !< File name for restart pointer file + character(len=240) :: restartpath !< Path of the restart file + integer :: mpicom_ocn !< MPI ocn communicator + integer :: npes, pe0 !< # of processors and current processor + integer :: i, errorCode + integer :: lsize, nsend, nrecv + logical :: ldiag_cpl = .false. + integer :: isc, iec, jsc, jec, ni, nj !< Indices for the start and end of the domain !! in the x and y dir., respectively. ! runtime params type(param_file_type) :: param_file !< A structure to parse for run-time parameters @@ -441,7 +171,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) gsMap=MOM_MCT_gsMap, dom=MOM_MCT_dom, infodata=glb%infodata) ! Determine attribute vector indices - call coupler_indices_init(glb%ind) + call cpl_indices_init(glb%ind) call seq_infodata_GetData( glb%infodata, case_name=runid ) @@ -482,15 +212,19 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! Debugging clocks if (debug .and. is_root_pe()) then write(glb%stdout,*) 'ocn_init_mct, current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + call ESMF_ClockGet(EClock, StartTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) write(glb%stdout,*) 'ocn_init_mct, start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + call ESMF_ClockGet(EClock, StopTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) write(glb%stdout,*) 'ocn_init_mct, stop time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + call ESMF_ClockGet(EClock, PrevTime=time_var, rc=rc) call ESMF_TimeGet(time_var, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc) write(glb%stdout,*) 'ocn_init_mct, previous time: y,m,d-',year,month,day,'h,m,s=',hour,minute,seconds + call ESMF_ClockGet(EClock, TimeStep=ocn_cpl_interval, rc=rc) call ESMF_TimeIntervalGet(ocn_cpl_interval, yy=year, mm=month, d=day, s=seconds, sn=seconds_n, sd=seconds_d, rc=rc) write(glb%stdout,*) 'ocn_init_mct, time step: y,m,d-',year,month,day,'s,sn,sd=',seconds,seconds_n,seconds_d @@ -501,6 +235,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) allocate(glb%ocn_public) glb%ocn_public%is_ocean_PE = .true. + allocate(glb%ocn_public%pelist(npes)) glb%ocn_public%pelist(:) = (/(i,i=pe0,pe0+npes)/) ! \todo Set other bits of glb$ocn_public @@ -509,9 +244,11 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! read useful runtime params call get_MOM_Input(param_file, dirs_tmp, check_params=.false.) !call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "POINTER_FILENAME", glb%pointer_filename, & "Name of the ascii file that contains the path and filename of" // & " the latest restart file.", default='rpointer.ocn') + call get_param(param_file, mdl, "SW_DECOMP", glb%sw_decomp, & "If True, read coeffs c1, c2, c3 and c4 and decompose" // & "the net shortwave radiation (SW) into four components:\n" // & @@ -519,16 +256,20 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) "visible, diffuse shortwave = c2 * SW \n" // & "near-IR, direct shortwave = c3 * SW \n" // & "near-IR, diffuse shortwave = c4 * SW", default=.true.) + if (glb%sw_decomp) then call get_param(param_file, mdl, "SW_c1", glb%c1, & "Coeff. used to convert net shortwave rad. into \n"//& "visible, direct shortwave.", units="nondim", default=0.285) + call get_param(param_file, mdl, "SW_c2", glb%c2, & "Coeff. used to convert net shortwave rad. into \n"//& "visible, diffuse shortwave.", units="nondim", default=0.285) + call get_param(param_file, mdl, "SW_c3", glb%c3, & "Coeff. used to convert net shortwave rad. into \n"//& "near-IR, direct shortwave.", units="nondim", default=0.215) + call get_param(param_file, mdl, "SW_c4", glb%c4, & "Coeff. used to convert net shortwave rad. into \n"//& "near-IR, diffuse shortwave.", units="nondim", default=0.215) @@ -538,11 +279,11 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! Initialize the MOM6 model runtype = get_runtype() - if (runtype == "initial") then ! startup (new run) - 'n' is needed below since we don't - ! specify input_filename in input.nml + if (runtype == "initial") then + ! startup (new run) - 'n' is needed below since we don't specify input_filename in input.nml call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time0, input_restart_file = 'n') - else ! hybrid or branch or continuos runs - ! output path root + else ! hybrid or branch or continuos runs + ! get output path root call seq_infodata_GetData( glb%infodata, outPathRoot=restartpath ) ! read name of restart file in the pointer file nu = shr_file_getUnit() @@ -552,17 +293,25 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) read(nu,'(a)') restartfile close(nu) !restartfile = trim(restartpath) // trim(restartfile) - if (is_root_pe()) write(glb%stdout,*) 'Reading restart file: ',trim(restartfile) - !endif + if (is_root_pe()) then + write(glb%stdout,*) 'Reading restart file: ',trim(restartfile) + end if call shr_file_freeUnit(nu) call ocean_model_init(glb%ocn_public, glb%ocn_state, time0, time0, input_restart_file=trim(restartfile)) endif + if (is_root_pe()) then + write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + end if ! Initialize ocn_state%sfc_state out of sight call ocean_model_init_sfc(glb%ocn_state, glb%ocn_public) - ! store pointers to components inside MOM - call get_state_pointers(glb%ocn_state, grid=glb%grid) + ! Store pointers to components inside MOM + glb%grid => glb%ocn_state%grid + + ! Allocate IOB data type (needs to be called after glb%grid is set) + write(6,*)'DEBUG: isc,iec,jsc,jec= ',glb%grid%isc, glb%grid%iec, glb%grid%jsc, glb%grid%jec + call IOB_allocate(ice_ocean_boundary, glb%grid%isc, glb%grid%iec, glb%grid%jsc, glb%grid%jec) call t_stopf('MOM_init') @@ -612,8 +361,8 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ncouple_per_day = seconds_in_day / ocn_cpl_dt mom_cpl_dt = seconds_in_day / ncouple_per_day if (mom_cpl_dt /= ocn_cpl_dt) then - write(glb%stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' - call exit(0) + write(glb%stdout,*) 'ERROR mom_cpl_dt and ocn_cpl_dt must be identical' + call exit(0) end if ! send initial state to driver @@ -623,23 +372,20 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) ! call seq_infodata_PutData( infodata, precip_fact=precip_fact) ! end if - if (debug .and. root_pe().eq.pe_here()) print *, "calling ocn_export" call ocn_export(glb%ind, glb%ocn_public, glb%grid, o2x_o%rattr) call t_stopf('MOM_mct_init') - if (debug .and. root_pe().eq.pe_here()) print *, "calling get_state_pointers" - ! Size of global domain call get_global_grid_size(glb%grid, ni, nj) 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" @@ -651,849 +397,7 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) end subroutine ocn_init_mct -!> Determines attribute vector indices -subroutine coupler_indices_init(ind) - - type(cpl_indices), intent(inout) :: ind !< Structure with coupler indices - !! and vectors - - ! Local Variables - type(mct_aVect) :: o2x !< Array with ocean to coupler data - type(mct_aVect) :: x2o !< Array with coupler to ocean data - - integer :: ncat !< Thickness category index - character(len=2) :: cncat !< Character version of ncat - integer :: ncol !< Column index - integer :: mcog_ncols !< Number of ice thickness categories? - integer :: lmcog_flds_sent !< Used to convert per thickness - !! category fields? - - ! create temporary attribute vectors - call mct_aVect_init(x2o, rList=seq_flds_x2o_fields, lsize=1) - call mct_aVect_init(o2x, rList=seq_flds_o2x_fields, lsize=1) - - ! ocean to coupler - ind%o2x_So_t = mct_avect_indexra(o2x,'So_t') - ind%o2x_So_u = mct_avect_indexra(o2x,'So_u') - ind%o2x_So_v = mct_avect_indexra(o2x,'So_v') - ind%o2x_So_s = mct_avect_indexra(o2x,'So_s') - ind%o2x_So_dhdx = mct_avect_indexra(o2x,'So_dhdx') - ind%o2x_So_dhdy = mct_avect_indexra(o2x,'So_dhdy') - ! QL, 150526, to wav, boundary layer depth - ind%o2x_So_bldepth = mct_avect_indexra(o2x,'So_bldepth') - ind%o2x_Fioo_q = mct_avect_indexra(o2x,'Fioo_q') - ind%o2x_Faoo_fco2_ocn = mct_avect_indexra(o2x,'Faoo_fco2_ocn',perrWith='quiet') - ind%o2x_Faoo_fdms_ocn = mct_avect_indexra(o2x,'Faoo_fdms_ocn',perrWith='quiet') - - ! coupler to ocean - ind%x2o_Si_ifrac = mct_avect_indexra(x2o,'Si_ifrac') - ind%x2o_Sa_pslv = mct_avect_indexra(x2o,'Sa_pslv') - ind%x2o_So_duu10n = mct_avect_indexra(x2o,'So_duu10n') - ! QL, 150526, from wav - ind%x2o_Sw_lamult = mct_avect_indexra(x2o,'Sw_lamult') - ind%x2o_Sw_ustokes = mct_avect_indexra(x2o,'Sw_ustokes') - ind%x2o_Sw_vstokes = mct_avect_indexra(x2o,'Sw_vstokes') - ind%x2o_Foxx_tauy = mct_avect_indexra(x2o,'Foxx_tauy') - ind%x2o_Foxx_taux = mct_avect_indexra(x2o,'Foxx_taux') - ind%x2o_Foxx_swnet = mct_avect_indexra(x2o,'Foxx_swnet') - ind%x2o_Foxx_lat = mct_avect_indexra(x2o,'Foxx_lat') - ind%x2o_Foxx_sen = mct_avect_indexra(x2o,'Foxx_sen') - ind%x2o_Foxx_lwup = mct_avect_indexra(x2o,'Foxx_lwup') - ind%x2o_Faxa_lwdn = mct_avect_indexra(x2o,'Faxa_lwdn') - ind%x2o_Fioi_melth = mct_avect_indexra(x2o,'Fioi_melth') - ind%x2o_Fioi_meltw = mct_avect_indexra(x2o,'Fioi_meltw') - ind%x2o_Fioi_salt = mct_avect_indexra(x2o,'Fioi_salt') - ind%x2o_Fioi_bcpho = mct_avect_indexra(x2o,'Fioi_bcpho') - ind%x2o_Fioi_bcphi = mct_avect_indexra(x2o,'Fioi_bcphi') - ind%x2o_Fioi_flxdst = mct_avect_indexra(x2o,'Fioi_flxdst') - ind%x2o_Faxa_prec = mct_avect_indexra(x2o,'Faxa_prec') - ind%x2o_Faxa_snow = mct_avect_indexra(x2o,'Faxa_snow') - ind%x2o_Faxa_rain = mct_avect_indexra(x2o,'Faxa_rain') - ind%x2o_Foxx_evap = mct_avect_indexra(x2o,'Foxx_evap') - ind%x2o_Foxx_rofl = mct_avect_indexra(x2o,'Foxx_rofl') - ind%x2o_Foxx_rofi = mct_avect_indexra(x2o,'Foxx_rofi') - ind%x2o_Faxa_bcphidry = mct_avect_indexra(x2o,'Faxa_bcphidry') - ind%x2o_Faxa_bcphodry = mct_avect_indexra(x2o,'Faxa_bcphodry') - ind%x2o_Faxa_bcphiwet = mct_avect_indexra(x2o,'Faxa_bcphiwet') - ind%x2o_Faxa_ocphidry = mct_avect_indexra(x2o,'Faxa_ocphidry') - ind%x2o_Faxa_ocphodry = mct_avect_indexra(x2o,'Faxa_ocphodry') - ind%x2o_Faxa_ocphiwet = mct_avect_indexra(x2o,'Faxa_ocphiwet') - ind%x2o_Faxa_dstdry1 = mct_avect_indexra(x2o,'Faxa_dstdry1') - ind%x2o_Faxa_dstdry2 = mct_avect_indexra(x2o,'Faxa_dstdry2') - ind%x2o_Faxa_dstdry3 = mct_avect_indexra(x2o,'Faxa_dstdry3') - ind%x2o_Faxa_dstdry4 = mct_avect_indexra(x2o,'Faxa_dstdry4') - ind%x2o_Faxa_dstwet1 = mct_avect_indexra(x2o,'Faxa_dstwet1') - ind%x2o_Faxa_dstwet2 = mct_avect_indexra(x2o,'Faxa_dstwet2') - ind%x2o_Faxa_dstwet3 = mct_avect_indexra(x2o,'Faxa_dstwet3') - ind%x2o_Faxa_dstwet4 = mct_avect_indexra(x2o,'Faxa_dstwet4') - ind%x2o_Sa_co2prog = mct_avect_indexra(x2o,'Sa_co2prog',perrWith='quiet') - ind%x2o_Sa_co2diag = mct_avect_indexra(x2o,'Sa_co2diag',perrWith='quiet') - ! optional per thickness category fields - - ! convert cpl indices to mcog column indices - ! this implementation only handles columns due to ice thickness categories - lmcog_flds_sent = seq_flds_i2o_per_cat - - if (seq_flds_i2o_per_cat) then - mcog_ncols = ice_ncat+1 - allocate(ind%x2o_frac_col(mcog_ncols)) - allocate(ind%x2o_fracr_col(mcog_ncols)) - allocate(ind%x2o_qsw_fracr_col(mcog_ncols)) - ncol = 1 - ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Sf_afrac') - ind%x2o_fracr_col(ncol) = mct_avect_indexra(x2o,'Sf_afracr') - 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) - enddo - else - mcog_ncols = 1 - endif - - call mct_aVect_clean(x2o) - call mct_aVect_clean(o2x) - -end subroutine coupler_indices_init - -!> Initializes the ocean model, including registering fields -!! for restarts and reading restart files if appropriate. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) - type(ocean_public_type), target, & - intent(inout) :: Ocean_sfc !< A structure containing various - !! publicly visible ocean surface properties after initialization, - !! the data in this type is intent(out). - type(ocean_state_type), pointer :: OS !< A structure whose internal - !! contents are private to ocean_model_mod that may be used to - !! contain all information about the ocean's interior state. - type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar - type(time_type), intent(in) :: Time_in !< The time at which to initialize the ocean model. - type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the - !! ocean and surface-ice fields that will participate - !! in the calculation of additional gas or other - !! tracer fluxes, and can be used to spawn related - !! internal variables in the ice model. - character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read - -! This subroutine initializes both the ocean state and the ocean surface type. -! Because of the way that indicies and domains are handled, Ocean_sfc must have -! been used in a previous call to initialize_ocean_type. - - real :: Rho0 !< The Boussinesq ocean density, in kg m-3. - real :: G_Earth !< The gravitational acceleration in m s-2. - !! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "ocean_model_init" !< This module's name. - character(len=48) :: stagger - logical :: use_temperature - integer :: secs, days - type(param_file_type) :: param_file !< A structure to parse for run-time parameters - - call callTree_enter("ocean_model_init(), ocn_comp_mct.F90") - if (associated(OS)) then - call MOM_error(WARNING, "ocean_model_init called with an associated "// & - "ocean_state_type structure. Model is already initialized.") - return - endif - allocate(OS) - - OS%is_ocean_pe = Ocean_sfc%is_ocean_pe - if (.not.OS%is_ocean_pe) return - - OS%Time = Time_in - call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & - input_restart_file=input_restart_file, diag_ptr=OS%diag, & - count_calls=.true.) - call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, C_p=OS%fluxes%C_p, & - use_temp=use_temperature) - OS%C_p = OS%fluxes%C_p - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "RESTART_CONTROL", OS%Restart_control, & - "An integer whose bits encode which restart files are \n"//& - "written. Add 2 (bit 1) for a time-stamped file, and odd \n"//& - "(bit 0) for a non-time-stamped file. A restart file \n"//& - "will be saved at the end of the run segment for any \n"//& - "non-negative value.", default=1) - call get_param(param_file, mdl, "OCEAN_SURFACE_STAGGER", stagger, & - "A case-insensitive character string to indicate the \n"//& - "staggering of the surface velocity field that is \n"//& - "returned to the coupler. Valid values include \n"//& - "'A', 'B', or 'C'.", default="C") - if (uppercase(stagger(1:1)) == 'A') then ; Ocean_sfc%stagger = AGRID - elseif (uppercase(stagger(1:1)) == 'B') then ; Ocean_sfc%stagger = BGRID_NE - elseif (uppercase(stagger(1:1)) == 'C') then ; Ocean_sfc%stagger = CGRID_NE - else ; call MOM_error(FATAL,"ocean_model_init: OCEAN_SURFACE_STAGGER = "// & - trim(stagger)//" is invalid.") ; endif - - call get_param(param_file, mdl, "RESTORE_SALINITY",OS%restore_salinity, & - "If true, the coupled driver will add a globally-balanced \n"//& - "fresh-water flux that drives sea-surface salinity \n"//& - "toward specified values.", default=.false.) - call get_param(param_file, mdl, "RESTORE_TEMPERATURE",OS%restore_temp, & - "If true, the coupled driver will add a \n"//& - "heat flux that drives sea-surface temperauture \n"//& - "toward specified values.", default=.false.) - call get_param(param_file, mdl, "RHO_0", Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) - call get_param(param_file, mdl, "G_EARTH", G_Earth, & - "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80) - - call get_param(param_file, mdl, "ICE_SHELF", OS%use_ice_shelf, & - "If true, enables the ice shelf model.", default=.false.) - - call get_param(param_file, mdl, "ICEBERGS_APPLY_RIGID_BOUNDARY", OS%icebergs_apply_rigid_boundary, & - "If true, allows icebergs to change boundary condition felt by ocean", default=.false.) - - if (OS%icebergs_apply_rigid_boundary) then - call get_param(param_file, mdl, "KV_ICEBERG", OS%kv_iceberg, & - "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) - call get_param(param_file, mdl, "DENSITY_ICEBERGS", OS%density_iceberg, & - "A typical density of icebergs.", units="kg m-3", default=917.0) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", OS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) - call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", OS%berg_area_threshold, & - "Fraction of grid cell which iceberg must occupy, so that fluxes \n"//& - "below berg are set to zero. Not applied for negative \n"//& - " values.", units="non-dim", default=-1.0) - endif - - OS%press_to_z = 1.0/(Rho0*G_Earth) - - ! Consider using a run-time flag to determine whether to do the diagnostic - ! vertical integrals, since the related 3-d sums are not negligible in cost. - call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & - do_integrals=.true., gas_fields_ocn=gas_fields_ocn) - - call surface_forcing_init(Time_in, OS%grid, param_file, OS%diag, & - OS%forcing_CSp, OS%restore_salinity, OS%restore_temp) - - if (OS%use_ice_shelf) then - call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) - endif - if (OS%icebergs_apply_rigid_boundary) then - !call allocate_forcing_type(OS%grid, OS%fluxes, iceberg=.true.) - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - if (.not. OS%use_ice_shelf) call allocate_forcing_type(OS%grid, OS%fluxes, ustar=.true., shelf=.true.) - endif - - if (ASSOCIATED(OS%grid%Domain%maskmap)) then - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, maskmap=OS%grid%Domain%maskmap, & - gas_fields_ocn=gas_fields_ocn) - else - call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & - OS%diag, gas_fields_ocn=gas_fields_ocn) - endif - - ! This call can only occur here if the coupler_bc_type variables have been - ! initialized already using the information from gas_fields_ocn. - if (present(gas_fields_ocn)) then - call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - endif - - call close_param_file(param_file) - call diag_mediator_close_registration(OS%diag) - - if (is_root_pe()) & - write(glb%stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' - - call callTree_leave("ocean_model_init(") -end subroutine ocean_model_init - -!> Extracts the surface properties from the ocean's internal -!! state and stores them in the ocean type returned to the calling ice model. -!! It has to be separate from the ocean_initialization call because the coupler -!! module allocates the space for some of these variables. -subroutine ocean_model_init_sfc(OS, Ocean_sfc) - type(ocean_state_type), pointer :: OS - type(ocean_public_type), intent(inout) :: Ocean_sfc - - integer :: is, ie, js, je - - is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec - call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - - call extract_surface_state(OS%MOM_CSp, OS%sfc_state) - - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - -end subroutine ocean_model_init_sfc - -!> Initializes surface forcing: get relevant parameters and allocate arrays. -subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, restore_temp) - type(time_type), intent(in) :: Time !< The current model time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - 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(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the - !! control structure for this module - logical, optional, intent(in) :: restore_salt, restore_temp !< If present and true, - !! temp/salt restoring will be applied - - ! local variables - real :: utide !< The RMS tidal velocity, in m s-1. - type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags - type(time_type) :: Time_frc - character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "ocn_comp_mct" ! This module's name. - character(len=48) :: stagger - character(len=240) :: basin_file - integer :: i, j, isd, ied, jsd, jed - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - if (associated(CS)) then - call MOM_error(WARNING, "surface_forcing_init called with an associated "// & - "control structure.") - return - endif - allocate(CS) - - id_clock_forcing=cpu_clock_id('Ocean surface forcing', grain=CLOCK_SUBCOMPONENT) - call cpu_clock_begin(id_clock_forcing) - - CS%diag => diag - - call write_version_number (version) - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - - call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & - "The directory in which all input files are found.", & - default=".") - CS%inputdir = slasher(CS%inputdir) - call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & - "If true, Temperature and salinity are used as state \n"//& - "variables.", default=.true.) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to \n"//& - "calculate accelerations and the mass for conservation \n"//& - "properties, or with BOUSSINSEQ false to convert some \n"//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0) - call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & - "The latent heat of fusion.", units="J/kg", default=hlf) - call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & - "The latent heat of fusion.", units="J/kg", default=hlv) - call get_param(param_file, mdl, "MAX_P_SURF", CS%max_p_surf, & - "The maximum surface pressure that can be exerted by the \n"//& - "atmosphere and floating sea-ice or ice shelves. This is \n"//& - "needed because the FMS coupling structure does not \n"//& - "limit the water that can be frozen out of the ocean and \n"//& - "the ice-ocean heat fluxes are treated explicitly. No \n"//& - "limit is applied if a negative value is used.", units="Pa", & - default=-1.0) - call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_TO_ZERO", & - CS%adjust_net_srestore_to_zero, & - "If true, adjusts the salinity restoring seen to zero\n"//& - "whether restoring is via a salt flux or virtual precip.",& - default=restore_salt) - call get_param(param_file, mdl, "ADJUST_NET_SRESTORE_BY_SCALING", & - CS%adjust_net_srestore_by_scaling, & - "If true, adjustments to salt restoring to achieve zero net are\n"//& - "made by scaling values without moving the zero contour.",& - default=.false.) - call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_TO_ZERO", & - CS%adjust_net_fresh_water_to_zero, & - "If true, adjusts the net fresh-water forcing seen \n"//& - "by the ocean (including restoring) to zero.", default=.false.) - call get_param(param_file, mdl, "ADJUST_NET_FRESH_WATER_BY_SCALING", & - CS%adjust_net_fresh_water_by_scaling, & - "If true, adjustments to net fresh water to achieve zero net are\n"//& - "made by scaling values without moving the zero contour.",& - default=.false.) - call get_param(param_file, mdl, "ICE_SALT_CONCENTRATION", & - CS%ice_salt_concentration, & - "The assumed sea-ice salinity needed to reverse engineer the \n"//& - "melt flux (or ice-ocean fresh-water flux).", & - units="kg/kg", default=0.005) - call get_param(param_file, mdl, "USE_LIMITED_PATM_SSH", CS%use_limited_P_SSH, & - "If true, return the sea surface height with the \n"//& - "correction for the atmospheric (and sea-ice) pressure \n"//& - "limited by max_p_surf instead of the full atmospheric \n"//& - "pressure.", default=.true.) - -! smg: should get_param call should be removed when have A=B code reconciled. -! this param is used to distinguish how to diagnose surface heat content from water. - call get_param(param_file, mdl, "BULKMIXEDLAYER", CS%bulkmixedlayer, & - default=CS%use_temperature,do_not_log=.true.) - - call get_param(param_file, mdl, "WIND_STAGGER", stagger, & - "A case-insensitive character string to indicate the \n"//& - "staggering of the input wind stress field. Valid \n"//& - "values are 'A', 'B', or 'C'.", default="C") - if (uppercase(stagger(1:1)) == 'A') then ; CS%wind_stagger = AGRID - elseif (uppercase(stagger(1:1)) == 'B') then ; CS%wind_stagger = BGRID_NE - elseif (uppercase(stagger(1:1)) == 'C') then ; CS%wind_stagger = CGRID_NE - else ; call MOM_error(FATAL,"surface_forcing_init: WIND_STAGGER = "// & - trim(stagger)//" is invalid.") ; endif - call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & - "A factor multiplying the wind-stress given to the ocean by the\n"//& - "coupler. This is used for testing and should be =1.0 for any\n"//& - "production runs.", default=1.0) - - if (restore_salt) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & - "A file in which to find the surface salinity to use for restoring.", & - default="salt_restore.nc") - call get_param(param_file, mdl, "SALT_RESTORE_VARIABLE", CS%salt_restore_var_name, & - "The name of the surface salinity variable to read from "//& - "SALT_RESTORE_FILE for restoring salinity.", & - default="salt") -! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 - - call get_param(param_file, mdl, "SRESTORE_AS_SFLUX", CS%salt_restore_as_sflux, & - "If true, the restoring of salinity is applied as a salt \n"//& - "flux instead of as a freshwater flux.", default=.false.) - call get_param(param_file, mdl, "MAX_DELTA_SRESTORE", CS%max_delta_srestore, & - "The maximum salinity difference used in restoring terms.", & - units="PSU or g kg-1", default=999.0) - call get_param(param_file, mdl, "MASK_SRESTORE_UNDER_ICE", & - CS%mask_srestore_under_ice, & - "If true, disables SSS restoring under sea-ice based on a frazil\n"//& - "criteria (SST<=Tf). Only used when RESTORE_SALINITY is True.", & - default=.false.) - call get_param(param_file, mdl, "MASK_SRESTORE_MARGINAL_SEAS", & - CS%mask_srestore_marginal_seas, & - "If true, disable SSS restoring in marginal seas. Only used when\n"//& - "RESTORE_SALINITY is True.", default=.false.) - call get_param(param_file, mdl, "BASIN_FILE", basin_file, & - "A file in which to find the basin masks, in variable 'basin'.", & - default="basin.nc") - basin_file = trim(CS%inputdir) // trim(basin_file) - call safe_alloc_ptr(CS%basin_mask,isd,ied,jsd,jed) ; CS%basin_mask(:,:) = 1.0 - if (CS%mask_srestore_marginal_seas) then - call read_data(basin_file,'basin',CS%basin_mask,domain=G%domain%mpp_domain,timelevel=1) - do j=jsd,jed ; do i=isd,ied - if (CS%basin_mask(i,j) >= 6.0) then ; CS%basin_mask(i,j) = 0.0 - else ; CS%basin_mask(i,j) = 1.0 ; endif - enddo ; enddo - endif - endif - - if (restore_temp) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & - "The constant that relates the restoring surface fluxes \n"//& - "to the relative surface anomalies (akin to a piston \n"//& - "velocity). Note the non-MKS units.", units="m day-1", & - fail_if_missing=.true.) - call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & - "A file in which to find the surface temperature to use for restoring.", & - default="temp_restore.nc") - call get_param(param_file, mdl, "SST_RESTORE_VARIABLE", CS%temp_restore_var_name, & - "The name of the surface temperature variable to read from "//& - "SST_RESTORE_FILE for restoring sst.", & - default="temp") -! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 - - call get_param(param_file, mdl, "MAX_DELTA_TRESTORE", CS%max_delta_trestore, & - "The maximum sst difference used in restoring terms.", & - units="degC ", default=999.0) - - endif - -! Optionally read tidal amplitude from input file (m s-1) on model grid. -! Otherwise use default tidal amplitude for bottom frictionally-generated -! dissipation. Default cd_tides is chosen to yield approx 1 TWatt of -! work done against tides globally using OSU tidal amplitude. - call get_param(param_file, mdl, "CD_TIDES", CS%cd_tides, & - "The drag coefficient that applies to the tides.", & - units="nondim", default=1.0e-4) - call get_param(param_file, mdl, "READ_TIDEAMP", CS%read_TIDEAMP, & - "If true, read a file (given by TIDEAMP_FILE) containing \n"//& - "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) - if (CS%read_TIDEAMP) then - call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & - "The path to the file containing the spatially varying \n"//& - "tidal amplitudes with INT_TIDE_DISSIPATION.", & - default="tideamp.nc") - CS%utide=0.0 - else - call get_param(param_file, mdl, "UTIDE", CS%utide, & - "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & - units="m s-1", default=0.0) - endif - - call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) - call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) - - if (CS%read_TIDEAMP) then - TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call read_data(TideAmp_file,'tideamp',CS%TKE_tidal,domain=G%domain%mpp_domain,timelevel=1) - do j=jsd, jed; do i=isd, ied - utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) - CS%ustar_tidal(i,j)=sqrt(CS%cd_tides)*utide - enddo ; enddo - else - do j=jsd,jed; do i=isd,ied - utide=CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) - CS%ustar_tidal(i,j)=sqrt(CS%cd_tides)*utide - enddo ; enddo - endif - - call time_interp_external_init - -! Optionally read a x-y gustiness field in place of a global -! constant. - - call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & - "If true, use a 2-dimensional gustiness supplied from \n"//& - "an input file", default=.false.) - call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & - "The background gustiness in the winds.", units="Pa", & - default=0.02) - if (CS%read_gust_2d) then - call get_param(param_file, mdl, "GUST_2D_FILE", gust_file, & - "The file in which the wind gustiness is found in \n"//& - "variable gustiness.") - - call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) - gust_file = trim(CS%inputdir) // trim(gust_file) - call read_data(gust_file,'gustiness',CS%gust,domain=G%domain%mpp_domain, & - timelevel=1) ! units should be Pa - endif - -! See whether sufficiently thick sea ice should be treated as rigid. - call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & - "If true, sea-ice is rigid enough to exert a \n"//& - "nonhydrostatic pressure that resist vertical motion.", & - default=.false.) - if (CS%rigid_sea_ice) then - call get_param(param_file, mdl, "SEA_ICE_MEAN_DENSITY", CS%density_sea_ice, & - "A typical density of sea ice, used with the kinematic \n"//& - "viscosity, when USE_RIGID_SEA_ICE is true.", units="kg m-3", & - default=900.0) - call get_param(param_file, mdl, "SEA_ICE_VISCOSITY", CS%Kv_sea_ice, & - "The kinematic viscosity of sufficiently thick sea ice \n"//& - "for use in calculating the rigidity of sea ice.", & - units="m2 s-1", default=1.0e9) - call get_param(param_file, mdl, "SEA_ICE_RIGID_MASS", CS%rigid_sea_ice_mass, & - "The mass of sea-ice per unit area at which the sea-ice \n"//& - "starts to exhibit rigidity", units="kg m-2", default=1000.0) - endif - - call get_param(param_file, mdl, "ALLOW_ICEBERG_FLUX_DIAGNOSTICS", iceberg_flux_diags, & - "If true, makes available diagnostics of fluxes from icebergs\n"//& - "as seen by MOM6.", default=.false.) - call register_forcing_type_diags(Time, diag, CS%use_temperature, CS%handles, & - use_berg_fluxes=iceberg_flux_diags) - - call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & - "If true, allows flux adjustments to specified via the \n"//& - "data_table using the component name 'OCN'.", default=.false.) - if (CS%allow_flux_adjustments) then - call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) - endif - - if (present(restore_salt)) then ; if (restore_salt) then - salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) - CS%id_srestore = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) - endif ; endif - - if (present(restore_temp)) then ; if (restore_temp) then - temp_file = trim(CS%inputdir) // trim(CS%temp_restore_file) - CS%id_trestore = init_external_field(temp_file, CS%temp_restore_var_name, domain=G%Domain%mpp_domain) - endif ; endif - - ! Set up any restart fields associated with the forcing. - call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") -!### call register_ctrl_forcing_restarts(G, param_file, CS%ctrl_forcing_CSp, & -!### CS%restart_CSp) - call restart_init_end(CS%restart_CSp) - - if (associated(CS%restart_CSp)) then - call Get_MOM_Input(dirs=dirs) - - new_sim = .false. - if ((dirs%input_filename(1:1) == 'n') .and. & - (LEN_TRIM(dirs%input_filename) == 1)) new_sim = .true. - if (.not.new_sim) then - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time_frc, & - G, CS%restart_CSp) - endif - endif - -!### call controlled_forcing_init(Time, G, param_file, diag, CS%ctrl_forcing_CSp) - - call user_revise_forcing_init(param_file, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) -end subroutine surface_forcing_init - -!> Initializes domain and state variables contained in the ocean public type. -subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, & - gas_fields_ocn) - type(domain2D), intent(in) :: input_domain !< The FMS domain for the input structure - type(ocean_public_type), intent(inout) :: Ocean_sfc !< Ocean surface state - type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. - logical, intent(in), optional :: maskmap(:,:) !< A pointer to an array indicating which - !! logical processors are actually used for the ocean code. - type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the - !! ocean and surface-ice fields that will participate - !! in the calculation of additional gas or other - !! tracer fluxes. - ! local variables - integer :: xsz, ysz, layout(2) - integer :: isc, iec, jsc, jec - - 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) - else - 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) - - allocate ( Ocean_sfc%t_surf (isc:iec,jsc:jec), & - Ocean_sfc%s_surf (isc:iec,jsc:jec), & - Ocean_sfc%u_surf (isc:iec,jsc:jec), & - Ocean_sfc%v_surf (isc:iec,jsc:jec), & - Ocean_sfc%sea_lev(isc:iec,jsc:jec), & - Ocean_sfc%area (isc:iec,jsc:jec), & - Ocean_sfc%frazil (isc:iec,jsc:jec)) - - Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model - Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models - Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav - Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model - Ocean_sfc%area = 0.0 - Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics - - if (present(gas_fields_ocn)) then - call coupler_type_spawn(gas_fields_ocn, Ocean_sfc%fields, (/isc,isc,iec,iec/), & - (/jsc,jsc,jec,jec/), suffix = '_ocn', as_needed=.true.) - endif - -end subroutine initialize_ocean_public_type - -!> Translates the coupler's ocean_data_type into MOM6's surface state variable. -!! This may eventually be folded into the MOM6's code that calculates the -!! surface state in the first place. -subroutine convert_state_to_ocean_type(state, Ocean_sfc, G, patm, press_to_z) - type(surface), intent(inout) :: state - type(ocean_public_type), target, intent(inout) :: Ocean_sfc !< Ocean surface state - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, optional, intent(in) :: patm(:,:) !< Atmospheric pressure. - real, optional, intent(in) :: press_to_z !< Factor to tranform atmospheric - !! pressure to z? - - ! local variables - real :: IgR0 - character(len=48) :: val_str - integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - integer :: i, j, i0, j0, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - call pass_vector(state%u,state%v,G%Domain) - - call mpp_get_compute_domain(Ocean_sfc%Domain, isc_bnd, iec_bnd, & - jsc_bnd, jec_bnd) - if (present(patm)) then - ! Check that the inidicies in patm are (isc_bnd:iec_bnd,jsc_bnd:jec_bnd). - if (.not.present(press_to_z)) call MOM_error(FATAL, & - 'convert_state_to_ocean_type: press_to_z must be present if patm is.') - endif - - i0 = is - isc_bnd ; j0 = js - jsc_bnd - if (state%T_is_conT) then - ! Convert the surface T from conservative T to potential T. - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = gsw_pt_from_ct(state%SSS(i+i0,j+j0), & - state%SST(i+i0,j+j0)) + CELSIUS_KELVIN_OFFSET - enddo ; enddo - else - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%t_surf(i,j) = state%SST(i+i0,j+j0) + CELSIUS_KELVIN_OFFSET - enddo ; enddo - endif - if (state%S_is_absS) then - ! Convert the surface S from absolute salinity to practical salinity. - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = gsw_sp_from_sr(state%SSS(i+i0,j+j0)) - enddo ; enddo - else - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%s_surf(i,j) = state%SSS(i+i0,j+j0) - enddo ; enddo - endif - - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%sea_lev(i,j) = state%sea_lev(i+i0,j+j0) - if (present(patm)) & - Ocean_sfc%sea_lev(i,j) = Ocean_sfc%sea_lev(i,j) + patm(i,j) * press_to_z - if (associated(state%frazil)) & - Ocean_sfc%frazil(i,j) = state%frazil(i+i0,j+j0) - Ocean_sfc%area(i,j) = G%areaT(i+i0,j+j0) - enddo ; enddo - - if (Ocean_sfc%stagger == AGRID) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I-1+i0,j+j0)) - Ocean_sfc%v_surf(i,j) = G%mask2dT(i+i0,j+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0,J-1+j0)) - enddo ; enddo - elseif (Ocean_sfc%stagger == BGRID_NE) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%u(I+i0,j+j0)+state%u(I+i0,j+j0+1)) - Ocean_sfc%v_surf(i,j) = G%mask2dBu(I+i0,J+j0)*0.5*(state%v(i+i0,J+j0)+state%v(i+i0+1,J+j0)) - enddo ; enddo - elseif (Ocean_sfc%stagger == CGRID_NE) then - do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd - Ocean_sfc%u_surf(i,j) = G%mask2dCu(I+i0,j+j0)*state%u(I+i0,j+j0) - Ocean_sfc%v_surf(i,j) = G%mask2dCv(i+i0,J+j0)*state%v(i+i0,J+j0) - enddo ; enddo - else - write(val_str, '(I8)') Ocean_sfc%stagger - call MOM_error(FATAL, "convert_state_to_ocean_type: "//& - "Ocean_sfc%stagger has the unrecognized value of "//trim(val_str)) - endif - - if (coupler_type_initialized(state%tr_fields)) then - if (.not.coupler_type_initialized(Ocean_sfc%fields)) then - call MOM_error(FATAL, "convert_state_to_ocean_type: "//& - "Ocean_sfc%fields has not been initialized.") - endif - call coupler_type_copy_data(state%tr_fields, Ocean_sfc%fields) - endif - -end subroutine convert_state_to_ocean_type - -!> Returns pointers to objects within ocean_state_type -subroutine get_state_pointers(OS, grid, surf) - type(ocean_state_type), pointer :: OS !< Ocean state type - type(ocean_grid_type), optional, pointer :: grid !< Ocean grid - type(surface), optional, pointer :: surf !< Ocean surface state - - if (present(grid)) grid => OS%grid - if (present(surf)) surf=> OS%sfc_state - -end subroutine get_state_pointers - -!> Maps outgoing ocean data to MCT buffer. -!! See \ref section_ocn_export for a summary of the data -!! that is transferred from MOM6 to MCT. -subroutine ocn_export(ind, ocn_public, grid, o2x) - type(cpl_indices), intent(inout) :: ind !< Structure with coupler - !! indices and vectors - type(ocean_public_type), intent(in) :: ocn_public !< Ocean surface state - type(ocean_grid_type), intent(in) :: grid !< Ocean model grid - real(kind=8), intent(inout) :: o2x(:,:) !< MCT outgoing bugger - ! Local variables - real, dimension(grid%isd:grid%ied,grid%jsd:grid%jed) :: ssh !< Local copy of sea_lev with updated halo - integer :: i, j, n, ig, jg !< Grid indices - real :: slp_L, slp_R, slp_C, slope, u_min, u_max - - ! Copy from ocn_public to o2x. ocn_public uses global indexing with no halos. - ! The mask comes from "grid" that uses the usual MOM domain that has halos - ! and does not use global indexing. - n = 0 - do j=grid%jsc, grid%jec - jg = j + grid%jdg_offset - do i=grid%isc,grid%iec - n = n+1 - ig = i + grid%idg_offset - ! surface temperature in Kelvin - o2x(ind%o2x_So_t, n) = ocn_public%t_surf(ig,jg) * grid%mask2dT(i,j) - o2x(ind%o2x_So_s, n) = ocn_public%s_surf(ig,jg) * grid%mask2dT(i,j) - o2x(ind%o2x_So_u, n) = ocn_public%u_surf(ig,jg) * grid%mask2dT(i,j) - o2x(ind%o2x_So_v, n) = ocn_public%v_surf(ig,jg) * grid%mask2dT(i,j) - ! Make a copy of ssh in order to do a halo update. We use the usual MOM domain - ! in order to update halos. i.e. does not use global indexing. - ssh(i,j) = ocn_public%sea_lev(ig,jg) - end do - end do - - ! Update halo of ssh so we can calculate gradients - call pass_var(ssh, grid%domain) - - ! d/dx ssh - n = 0 - do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec - n = n+1 - ! This is a simple second-order difference - !o2x(ind%o2x_So_dhdx, n) = 0.5 * (ssh(i+1,j) - ssh(i-1,j)) * grid%IdxT(i,j) * grid%mask2dT(i,j) - ! This is a PLM slope which might be less prone to the A-grid null mode - slp_L = (ssh(I,j) - ssh(I-1,j)) * grid%mask2dCu(I-1,j) - if (grid%mask2dCu(I-1,j)==0.) slp_L = 0. - slp_R = (ssh(I+1,j) - ssh(I,j)) * grid%mask2dCu(I,j) - if (grid%mask2dCu(I+1,j)==0.) slp_R = 0. - slp_C = 0.5 * (slp_L + slp_R) - if ( (slp_L * slp_R) > 0.0 ) then - ! This limits the slope so that the edge values are bounded by the - ! two cell averages spanning the edge. - u_min = min( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) - u_max = max( ssh(i-1,j), ssh(i,j), ssh(i+1,j) ) - slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - end if - o2x(ind%o2x_So_dhdx, n) = slope * grid%IdxT(i,j) * grid%mask2dT(i,j) - if (grid%mask2dT(i,j)==0.) o2x(ind%o2x_So_dhdx, n) = 0.0 - end do; end do - - ! d/dy ssh - n = 0 - do j=grid%jsc, grid%jec ; do i=grid%isc,grid%iec - n = n+1 - ! This is a simple second-order difference - !o2x(ind%o2x_So_dhdy, n) = 0.5 * (ssh(i,j+1) - ssh(i,j-1)) * grid%IdyT(i,j) * grid%mask2dT(i,j) - ! This is a PLM slope which might be less prone to the A-grid null mode - slp_L = ssh(i,J) - ssh(i,J-1) * grid%mask2dCv(i,J-1) - if (grid%mask2dCv(i,J-1)==0.) slp_L = 0. - slp_R = ssh(i,J+1) - ssh(i,J) * grid%mask2dCv(i,J) - if (grid%mask2dCv(i,J+1)==0.) slp_R = 0. - slp_C = 0.5 * (slp_L + slp_R) - !write(6,*)'slp_L, slp_R,i,j,slp_L*slp_R', slp_L, slp_R,i,j,slp_L*slp_R - if ((slp_L * slp_R) > 0.0) then - ! This limits the slope so that the edge values are bounded by the - ! two cell averages spanning the edge. - u_min = min( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) - u_max = max( ssh(i,j-1), ssh(i,j), ssh(i,j+1) ) - slope = sign( min( abs(slp_C), 2.*min( ssh(i,j) - u_min, u_max - ssh(i,j) ) ), slp_C ) - else - ! Extrema in the mean values require a PCM reconstruction avoid generating - ! larger extreme values. - slope = 0.0 - end if - o2x(ind%o2x_So_dhdy, n) = slope * grid%IdyT(i,j) * grid%mask2dT(i,j) - if (grid%mask2dT(i,j)==0.) o2x(ind%o2x_So_dhdy, n) = 0.0 - end do; end do - -end subroutine ocn_export +!======================================================================= !> Step forward ocean model for coupling interval subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) @@ -1583,10 +487,21 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) ! GMM, check if this is needed! call seq_cdata_setptrs(cdata_o, infodata=glb%infodata) - call update_ocean_model(glb%ocn_state, glb%ocn_public, time_start, coupling_timestep, & - x2o_o%rattr, glb%ind, glb%sw_decomp, glb%c1, glb%c2, glb%c3, glb%c4) + ! Translate import fields to ice_ocean_boundary + !TODO: make this an input variable + !glb%sw_decomp = .false. + !END TODO: + if (glb%sw_decomp) then + call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, glb%stdout, Eclock, & + c1=glb%c1, c2=glb%c2, c3=glb%c3, c4=glb%c4) + else + call ocn_import(x2o_o%rattr, glb%ind, glb%grid, Ice_ocean_boundary, glb%ocn_public, glb%stdout, Eclock ) + end if + + ! Update internal ocean + call update_ocean_model(ice_ocean_boundary, glb%ocn_state, glb%ocn_public, time_start, coupling_timestep) - ! return export state to driver + ! Return export state to driver call ocn_export(glb%ind, glb%ocn_public, glb%grid, o2x_o%rattr) !--- write out intermediate restart file when needed. @@ -1604,7 +519,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') trim(runid), year, month, day, seconds call save_restart(glb%ocn_state%dirs%restart_output_dir, glb%ocn_state%Time, glb%grid, & - glb%ocn_state%restart_CSp, .false., filename=restartname,GV=glb%ocn_state%GV) + glb%ocn_state%restart_CSp, .false., filename=restartname, GV=glb%ocn_state%GV) ! write name of restart file in the rpointer file nu = shr_file_getUnit() @@ -1620,9 +535,11 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) ! Is this needed? call forcing_save_restart(glb%ocn_state%forcing_CSp, glb%grid, glb%ocn_state%Time, & glb%ocn_state%dirs%restart_output_dir, .true.) + ! Once we start using the ice shelf module, the following will be needed if (glb%ocn_state%use_ice_shelf) then - call ice_shelf_save_restart(glb%ocn_state%Ice_shelf_CSp, glb%ocn_state%Time, glb%ocn_state%dirs%restart_output_dir, .true.) + call ice_shelf_save_restart(glb%ocn_state%Ice_shelf_CSp, glb%ocn_state%Time, & + glb%ocn_state%dirs%restart_output_dir, .true.) endif endif @@ -1635,783 +552,7 @@ subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) end subroutine ocn_run_mct -!> Saves restart fields associated with the forcing -subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & - filename_suffix) - type(surface_forcing_CS), pointer :: CS !< pointer to the control structure - !! returned by a previous call to - !! surface_forcing_init - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time !< model time at this call - character(len=*), intent(in) :: directory !< optional directory into which - !! to write these restart files - logical, optional, intent(in) :: time_stamped !< If true, the restart file - !! names include a unique time - !! stamp - character(len=*), optional, intent(in) :: filename_suffix !< optional suffix - !! (e.g., a time-stamp) to append to the - !! restart file names - if (.not.associated(CS)) return - if (.not.associated(CS%restart_CSp)) return - call save_restart(directory, Time, G, CS%restart_CSp, time_stamped) - -end subroutine forcing_save_restart - -!> Updates the ocean model fields. This code wraps the call to step_MOM with MOM6's call. -!! It uses the forcing to advance the ocean model's state from the -!! input value of Ocean_state (which must be for time time_start_update) for a time interval -!! of Ocean_coupling_time_step, returning the publicly visible ocean surface properties in -!! Ocean_sfc and storing the new ocean properties in Ocean_state. -subroutine update_ocean_model(OS, Ocean_sfc, time_start_update, & - Ocean_coupling_time_step, x2o_o, ind, sw_decomp, & - c1, c2, c3, c4) - type(ocean_state_type), pointer :: OS !< Structure containing the internal ocean state - type(ocean_public_type), intent(inout) :: Ocean_sfc !< Structure containing all the publicly - !! visible ocean surface fields after a coupling time step - type(time_type), intent(in) :: time_start_update !< Time at the beginning of the update step - type(time_type), intent(in) :: Ocean_coupling_time_step !< Amount of time over which to - !! advance the ocean - real(kind=8), intent(in) :: x2o_o(:,:) !< Fluxes from coupler to ocean, computed by ocean - type(cpl_indices), intent(inout) :: ind !< Structure with MCT attribute vectors and indices - logical, intent(in) :: sw_decomp !< controls if shortwave is - !!decomposed into four components - real(kind=8), intent(in), optional :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition - - ! local variables - type(time_type) :: Master_time !< This allows step_MOM to temporarily change - !! the time that is seen by internal modules. - type(time_type) :: Time1 !< The value of the ocean model's time at the - !! start of a call to step_MOM. - real :: weight !< Flux accumulation weight - real :: time_step !< The time step of a call to step_MOM in seconds. - integer :: secs, days - integer :: is, ie, js, je - - call callTree_enter("update_ocean_model(), ocn_comp_mct.F90") - call get_time(Ocean_coupling_time_step, secs, days) - time_step = 86400.0*real(days) + real(secs) - - if (time_start_update /= OS%Time) then - call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& - "agree with time_start_update argument.") - endif - - if (.not.associated(OS)) then - call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & - "ocean_state_type structure. ocean_model_init must be "// & - "called first to allocate this structure.") - return - endif - - ! This is benign but not necessary if ocean_model_init_sfc was called or if - ! OS%sfc_state%tr_fields was spawned in ocean_model_init. Consider removing it. - is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec - call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) - - weight = 1.0 - - if (OS%fluxes%fluxes_used) then - ! GMM, is enable_averaging needed now? - call enable_averaging(time_step, OS%Time + Ocean_coupling_time_step, OS%diag) - call ocn_import(OS%forces, OS%fluxes, OS%Time, OS%grid, OS%forcing_CSp, OS%sfc_state, x2o_o, ind, sw_decomp, & - c1, c2, c3, c4, OS%restore_salinity,OS%restore_temp) - - ! Fields that exist in both the forcing and mech_forcing types must be copied. - call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) - -#ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes -#endif - - ! Add ice shelf fluxes - if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%fluxes, OS%Time, time_step, OS%Ice_shelf_CSp) - endif - - ! GMM, check ocean_model_MOM.F90 to enable the following option - !if (OS%icebergs_apply_rigid_boundary) then - ! This assumes that the iceshelf and ocean are on the same grid. I hope this is true. - ! call add_berg_flux_to_shelf(OS%grid, OS%forces,OS%fluxes,OS%use_ice_shelf,OS%density_iceberg,OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) - !endif - - ! Indicate that there are new unused fluxes. - OS%fluxes%fluxes_used = .false. - OS%fluxes%dt_buoy_accum = time_step - else - OS%flux_tmp%C_p = OS%fluxes%C_p - ! Import fluxes from coupler to ocean. Also, perform do SST and SSS restoring, if needed. - call ocn_import(OS%forces, OS%flux_tmp, OS%Time, OS%grid, OS%forcing_CSp, & - OS%sfc_state, x2o_o, ind, sw_decomp, c1, c2, c3, c4, & - OS%restore_salinity,OS%restore_temp) - - if (OS%use_ice_shelf) then - call shelf_calc_flux(OS%sfc_state, OS%forces, OS%flux_tmp, OS%Time, time_step, OS%Ice_shelf_CSp) - endif - - ! GMM, check ocean_model_MOM.F90 to enable the following option - !if (OS%icebergs_apply_rigid_boundary) then - !This assumes that the iceshelf and ocean are on the same grid. I hope this is true - ! call add_berg_flux_to_shelf(OS%grid, OS%forces, OS%flux_tmp, OS%use_ice_shelf,OS%density_iceberg,OS%kv_iceberg, OS%latent_heat_fusion, OS%sfc_state, time_step, OS%berg_area_threshold) - !endif - - ! Accumulate the forcing over time steps - call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, time_step, OS%grid, weight) - ! Some of the fields that exist in both the forcing and mech_forcing types - ! are time-averages must be copied back to the forces type. - call copy_back_forcing_fields(OS%fluxes, OS%forces, OS%grid) -#ifdef _USE_GENERIC_TRACER - call MOM_generic_tracer_fluxes_accumulate(OS%flux_tmp, weight) !weight of the current flux in the running average -#endif - endif - - call set_derived_forcing_fields(OS%forces, OS%fluxes, OS%grid, OS%GV%Rho0) - call set_net_mass_forcing(OS%fluxes, OS%forces, OS%grid) - - if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%fluxes, & - OS%restart_CSp) - endif - - call disable_averaging(OS%diag) - Master_time = OS%Time ; Time1 = OS%Time - - if(OS%offline_tracer_mode) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) - else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, time_step, OS%MOM_CSp) - endif - - OS%Time = Master_time + Ocean_coupling_time_step - OS%nstep = OS%nstep + 1 - - call enable_averaging(time_step, OS%Time, OS%diag) - call mech_forcing_diags(OS%forces, OS%fluxes, time_step, OS%grid, & - OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) - - if (OS%fluxes%fluxes_used) then - call enable_averaging(OS%fluxes%dt_buoy_accum, OS%Time, OS%diag) - call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%fluxes%dt_buoy_accum, & - OS%grid, OS%diag, OS%forcing_CSp%handles) - call disable_averaging(OS%diag) - endif - -! Translate state into Ocean. -! call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid, & -! Ice_ocean_boundary%p, OS%press_to_z) - call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) - - call callTree_leave("update_ocean_model()") -end subroutine update_ocean_model - -!> This function has a few purposes: 1) it allocates and initializes the data -!! in the fluxes structure; 2) it imports surface fluxes using data from -!! the coupler; and 3) it can apply restoring in SST and SSS. -!! See \ref section_ocn_import for a summary of the surface fluxes that are -!! passed from MCT to MOM6, including fluxes that need to be included in -!! the future. -subroutine ocn_import(forces, fluxes, Time, G, CS, state, x2o_o, ind, sw_decomp, & - c1, c2, c3, c4, restore_salt, restore_temp) - type(mech_forcing), intent(inout) :: forces !< Driving mechanical forces - type(forcing), intent(inout) :: fluxes !< Surface fluxes - type(time_type), intent(in) :: Time !< Model time - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid - type(surface_forcing_CS), pointer :: CS !< control structure returned by - !! a previous call to surface_forcing_init - type(surface), intent(in) :: state !< control structure to ocean - !! surface state fields. - real(kind=8), intent(in) :: x2o_o(:,:)!< Fluxes from coupler to ocean, computed by ocean - type(cpl_indices), intent(inout) :: ind !< Structure with MCT attribute vectors and indices - logical, intent(in) :: sw_decomp !< controls if shortwave is - !!decomposed into four components - real(kind=8), intent(in), optional :: c1, c2, c3, c4 !< Coeffs. used in the shortwave decomposition - logical, optional, intent(in) :: restore_salt, restore_temp !< Controls if salt and temp are - !! restored - - ! local variables - real, dimension(SZIB_(G),SZJB_(G)) :: & - taux_at_q, & ! Zonal wind stresses at q points (Pa) - tauy_at_q ! Meridional wind stresses at q points (Pa) - - real, dimension(SZI_(G),SZJ_(G)) :: & - taux_at_h, & ! Zonal wind stresses at h points (Pa) - tauy_at_h, & ! Meridional wind stresses at h points (Pa) - data_restore, & ! The surface value toward which to restore (g/kg or degC) - SST_anom, & ! Instantaneous sea surface temperature anomalies from a target value (deg C) - SSS_anom, & ! Instantaneous sea surface salinity anomalies from a target value (g/kg) - SSS_mean, & ! A (mean?) salinity about which to normalize local salinity - ! anomalies when calculating restorative precipitation anomalies (g/kg) - PmE_adj, & ! The adjustment to PminusE that will cause the salinity - ! to be restored toward its target value (kg/(m^2 * s)) - net_FW, & ! The area integrated net freshwater flux into the ocean (kg/s) - net_FW2, & ! The area integrated net freshwater flux into the ocean (kg/s) - work_sum, & ! A 2-d array that is used as the work space for a global - ! sum, used with units of m2 or (kg/s) - open_ocn_mask ! a binary field indicating where ice is present based on frazil criteria - - real :: gustiness ! unresolved gustiness that contributes to ustar (Pa) - real :: Irho0 ! inverse of the mean density in (m^3/kg) - real :: taux2, tauy2 ! squared wind stresses (Pa^2) - real :: tau_mag ! magnitude of the wind stress (Pa) - real :: I_GEarth ! 1.0 / G%G_Earth (s^2/m) - real :: Kv_rho_ice ! (CS%kv_sea_ice / CS%density_sea_ice) ( m^5/(s*kg) ) - real :: mass_ice ! mass of sea ice at a face (kg/m^2) - real :: mass_eff ! effective mass of sea ice for rigidity (kg/m^2) - - integer :: wind_stagger ! AGRID, BGRID_NE, or CGRID_NE (integers from MOM_domains) - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer - integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd - - logical :: restore_salinity ! local copy of the argument restore_salt, if it - ! is present, or false (no restoring) otherwise. - logical :: restore_sst ! local copy of the argument restore_temp, if it - ! is present, or false (no restoring) otherwise. - real :: delta_sss ! temporary storage for sss diff from restoring value - real :: delta_sst ! temporary storage for sst diff from restoring value - - real :: C_p ! heat capacity of seawater ( J/(K kg) ) - - call cpu_clock_begin(id_clock_forcing) - - 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 - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 - - C_p = fluxes%C_p - Irho0 = 1.0/CS%Rho0 - open_ocn_mask(:,:) = 1.0 - pme_adj(:,:) = 0.0 - fluxes%vPrecGlobalAdj = 0.0 - fluxes%vPrecGlobalScl = 0.0 - fluxes%saltFluxGlobalAdj = 0.0 - fluxes%saltFluxGlobalScl = 0.0 - fluxes%netFWGlobalAdj = 0.0 - fluxes%netFWGlobalScl = 0.0 - - restore_salinity = .false. - if (present(restore_salt)) restore_salinity = restore_salt - restore_sst = .false. - if (present(restore_temp)) restore_sst = restore_temp - - ! if true, allocation and initialization - if (fluxes%dt_buoy_accum < 0) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., & - ustar=.true., press=.true.) - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) - call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%sw_nir_dif,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_in,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - - call safe_alloc_ptr(fluxes%TKE_tidal,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%ustar_tidal,isd,ied,jsd,jed) - - if (CS%allow_flux_adjustments) then - call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) - endif - - 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 - - call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) - call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) - - if (CS%rigid_sea_ice) then - call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) - call safe_alloc_ptr(forces%rigidity_ice_v,isd,ied,JsdB,JedB) - endif - - if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) - - fluxes%dt_buoy_accum = 0.0 - endif ! endif for allocation and initialization - - if (CS%allow_flux_adjustments) then - fluxes%heat_added(:,:)=0.0 - fluxes%salt_flux_added(:,:)=0.0 - endif - - if (CS%area_surf < 0.0) then - do j=js,je ; do i=is,ie - work_sum(i,j) = G%areaT(i,j) * G%mask2dT(i,j) - enddo ; enddo - CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) - endif ! endif for allocation and initialization - - do j=js,je ; do i=is,ie - fluxes%salt_flux(i,j) = 0.0 - fluxes%vprec(i,j) = 0.0 - enddo ; enddo - - ! Salinity restoring logic - if (restore_salinity) then - call time_interp_external(CS%id_srestore,Time,data_restore) - ! open_ocn_mask indicates where to restore salinity (1 means restore, 0 does not) - open_ocn_mask(:,:) = 1.0 - if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice - do j=js,je ; do i=is,ie - if (state%SST(i,j) .le. -0.0539*state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo - endif - if (CS%salt_restore_as_sflux) then - do j=js,je ; do i=is,ie - delta_sss = data_restore(i,j)- state%SSS(i,j) - 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)) *delta_sss ! kg Salt m-2 s-1 - 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) - fluxes%saltFluxGlobalAdj = 0. - else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj = reproducing_sum(work_sum(:,:), isr,ier, jsr,jer)/CS%area_surf - fluxes%salt_flux(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) - fluxes%saltFluxGlobalAdj - endif - endif - 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 - delta_sss = 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%Rho0*CS%Flux_const) * & - delta_sss / (0.5*(state%SSS(i,j) + data_restore(i,j))) - endif - 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) - fluxes%vPrecGlobalAdj = 0. - else - work_sum(is:ie,js:je) = G%areaT(is:ie,js:je)*fluxes%vprec(is:ie,js:je) - 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) - fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo - endif - endif - endif - endif - - ! SST restoring logic - if (restore_sst) then - call time_interp_external(CS%id_trestore,Time,data_restore) - do j=js,je ; do i=is,ie - delta_sst = data_restore(i,j)- state%SST(i,j) - 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%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 - enddo; enddo - endif - - ! GMM, CIME uses AGRID. All the BGRID_NE code can be cleaned later - wind_stagger = AGRID - - if (wind_stagger == BGRID_NE) then - ! This is necessary to fill in the halo points. - taux_at_q(:,:) = 0.0 ; tauy_at_q(:,:) = 0.0 - endif - if (wind_stagger == AGRID) then - ! This is necessary to fill in the halo points. - taux_at_h(:,:) = 0.0 ; tauy_at_h(:,:) = 0.0 - endif - - k = 0 - do j=js,je ; do i=is,ie - k = k + 1 ! Increment position within gindex - - if (wind_stagger == BGRID_NE) then - taux_at_q(I,J) = x2o_o(ind%x2o_Foxx_taux,k) * CS%wind_stress_multiplier - tauy_at_q(I,J) = x2o_o(ind%x2o_Foxx_tauy,k) * CS%wind_stress_multiplier - ! GMM, cime uses AGRID - elseif (wind_stagger == AGRID) then - taux_at_h(i,j) = x2o_o(ind%x2o_Foxx_taux,k) * CS%wind_stress_multiplier - tauy_at_h(i,j) = x2o_o(ind%x2o_Foxx_tauy,k) * CS%wind_stress_multiplier - else ! C-grid wind stresses. - forces%taux(I,j) = x2o_o(ind%x2o_Foxx_taux,k) * CS%wind_stress_multiplier - forces%tauy(i,J) = x2o_o(ind%x2o_Foxx_tauy,k) * CS%wind_stress_multiplier - endif - - ! liquid precipitation (rain) - if (ASSOCIATED(fluxes%lprec)) & - fluxes%lprec(i,j) = x2o_o(ind%x2o_Faxa_rain,k) * G%mask2dT(i,j) - - ! frozen precipitation (snow) - if (ASSOCIATED(fluxes%fprec)) & - fluxes%fprec(i,j) = x2o_o(ind%x2o_Faxa_snow,k) * G%mask2dT(i,j) - - ! evaporation - if (ASSOCIATED(fluxes%evap)) & - fluxes%evap(i,j) = x2o_o(ind%x2o_Foxx_evap,k) * G%mask2dT(i,j) - - ! river runoff flux - if (ASSOCIATED(fluxes%lrunoff)) & - fluxes%lrunoff(i,j) = x2o_o(ind%x2o_Foxx_rofl,k) * G%mask2dT(i,j) - - ! ice runoff flux - if (ASSOCIATED(fluxes%frunoff)) & - fluxes%frunoff(i,j) = x2o_o(ind%x2o_Foxx_rofi,k) * G%mask2dT(i,j) - - ! GMM, we don't have an icebergs yet so the following is not needed - !if (((ASSOCIATED(IOB%ustar_berg) .and. (.not. ASSOCIATED(fluxes%ustar_berg))) & - ! .or. (ASSOCIATED(IOB%area_berg) .and. (.not. ASSOCIATED(fluxes%area_berg)))) & - ! .or. (ASSOCIATED(IOB%mass_berg) .and. (.not. ASSOCIATED(fluxes%mass_berg)))) & - ! call allocate_forcing_type(G, fluxes, iceberg=.true.) - !if (ASSOCIATED(IOB%ustar_berg)) & - ! fluxes%ustar_berg(i,j) = 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) - !if (ASSOCIATED(IOB%mass_berg)) & - ! fluxes%mass_berg(i,j) = 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 seeting these to zero for now. - if (ASSOCIATED(fluxes%heat_content_lrunoff)) & - fluxes%heat_content_lrunoff(i,j) = 0.0 * G%mask2dT(i,j) - - if (ASSOCIATED(fluxes%heat_content_frunoff)) & - fluxes%heat_content_frunoff(i,j) = 0.0 * G%mask2dT(i,j) - - ! longwave radiation, sum up and down (W/m2) - if (ASSOCIATED(fluxes%LW)) & - fluxes%LW(i,j) = (x2o_o(ind%x2o_Faxa_lwdn,k) + x2o_o(ind%x2o_Foxx_lwup,k)) * G%mask2dT(i,j) - - ! sensible heat flux (W/m2) - if (ASSOCIATED(fluxes%sens)) & - fluxes%sens(i,j) = x2o_o(ind%x2o_Foxx_sen,k) * G%mask2dT(i,j) - - ! latent heat flux (W/m^2) - if (ASSOCIATED(fluxes%latent)) & - fluxes%latent(i,j) = x2o_o(ind%x2o_Foxx_lat,k) * G%mask2dT(i,j) - - if (sw_decomp) then - ! Use runtime coefficients to decompose net short-wave heat flux into 4 components - ! 1) visible, direct shortwave (W/m2) - if (ASSOCIATED(fluxes%sw_vis_dir)) & - fluxes%sw_vis_dir(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Foxx_swnet,k)*c1 - ! 2) visible, diffuse shortwave (W/m2) - if (ASSOCIATED(fluxes%sw_vis_dif)) & - fluxes%sw_vis_dif(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Foxx_swnet,k)*c2 - ! 3) near-IR, direct shortwave (W/m2) - if (ASSOCIATED(fluxes%sw_nir_dir)) & - fluxes%sw_nir_dir(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Foxx_swnet,k)*c3 - ! 4) near-IR, diffuse shortwave (W/m2) - if (ASSOCIATED(fluxes%sw_nir_dif)) & - fluxes%sw_nir_dif(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Foxx_swnet,k)*c4 - - 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) - else - call MOM_error(FATAL,"fill_ice_ocean_bnd: this option has not been implemented yet."// & - "Shortwave must be decomposed using coeffs. c1, c2, c3, c4."); - endif - - ! applied surface pressure from atmosphere and cryosphere - ! sea-level pressure (Pa) - if (ASSOCIATED(forces%p_surf_full) .and. ASSOCIATED(forces%p_surf)) then - forces%p_surf_full(i,j) = G%mask2dT(i,j) * x2o_o(ind%x2o_Sa_pslv,k) - if (CS%max_p_surf >= 0.0) then - forces%p_surf(i,j) = MIN(forces%p_surf_full(i,j),CS%max_p_surf) - else - forces%p_surf(i,j) = forces%p_surf_full(i,j) - endif - - if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf - else - forces%p_surf_SSH => forces%p_surf_full - endif - - endif - - ! salt flux - ! more salt restoring logic - if (ASSOCIATED(fluxes%salt_flux)) & - fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(x2o_o(ind%x2o_Fioi_salt,k) + fluxes%salt_flux(i,j)) - - if (ASSOCIATED(fluxes%salt_flux_in)) & - fluxes%salt_flux_in(i,j) = G%mask2dT(i,j)*x2o_o(ind%x2o_Fioi_salt,k) - - enddo ; enddo - ! ############################ END OF MCT to MOM ############################## - - ! adjust the NET fresh-water flux to zero, if flagged - if (CS%adjust_net_fresh_water_to_zero) then - do j=js,je ; do i=is,ie - net_FW(i,j) = (((fluxes%lprec(i,j) + fluxes%fprec(i,j)) + & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & - (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * G%areaT(i,j) - ! The following contribution appears to be calculating the volume flux of sea-ice - ! melt. This calculation is clearly WRONG if either sea-ice has variable - ! salinity or the sea-ice is completely fresh. - ! Bob thinks this is trying ensure the net fresh-water of the ocean + sea-ice system - ! is constant. - ! To do this correctly we will need a sea-ice melt field added to IOB. -AJA - if (ASSOCIATED(fluxes%salt_flux) .and. (CS%ice_salt_concentration>0.0)) & - net_FW(i,j) = net_FW(i,j) + G%areaT(i,j) * & - (fluxes%salt_flux(i,j) / CS%ice_salt_concentration) - net_FW2(i,j) = net_FW(i,j)/G%areaT(i,j) - 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) + (net_FW2(i,j) - net_FW(i,j)/G%areaT(i,j)) * G%mask2dT(i,j) - 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) - fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo - endif - - endif - - ! surface momentum stress related fields as function of staggering - if (wind_stagger == BGRID_NE) then - if (G%symmetric) & - call fill_symmetric_edges(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - call pass_vector(taux_at_q, tauy_at_q, G%Domain, stagger=BGRID_NE) - - 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) & - 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 - - 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) & - 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 - - ! 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 - ! in regions of very weak winds. - - 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 - 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) + & - G%mask2dBu(I-1,J)*(taux_at_q(I-1,J)**2 + tauy_at_q(I-1,J)**2)) ) / & - ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) ) - if (CS%read_gust_2d) gustiness = CS%gust(i,j) - endif - forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) - enddo ; enddo - - elseif (wind_stagger == AGRID) then - call pass_vector(taux_at_h, tauy_at_h, G%Domain,stagger=AGRID) - - 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) & - 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 - - 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) & - 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 - - 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) - 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 - - else ! C-grid wind stresses. - if (G%symmetric) & - call fill_symmetric_edges(forces%taux, forces%tauy, G%Domain) - call pass_vector(forces%taux, forces%tauy, G%Domain) - - do j=js,je ; do i=is,ie - taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 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) & - 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)) - - if (CS%read_gust_2d) then - forces%ustar(i,j) = sqrt(CS%gust(i,j)*Irho0 + Irho0*sqrt(taux2 + tauy2)) - else - forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) - endif - enddo ; enddo - - endif ! endif for wind related fields - - - ! sea ice related fields - if (CS%rigid_sea_ice) then - ! The commented out code here and in the following lines is the correct - ! version, but the incorrect version is being retained temporarily to avoid - ! changing answers. - call pass_var(forces%p_surf_full, G%Domain) - I_GEarth = 1.0 / G%G_Earth - Kv_rho_ice = (CS%kv_sea_ice / CS%density_sea_ice) - do I=isd,ied-1 ; do j=jsd,jed - mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i+1,j)) * I_GEarth - mass_eff = 0.0 - if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) - endif - ! CAUTION: with both rigid_sea_ice and ice shelves, we will need to make this - ! a maximum for the second call. - forces%rigidity_ice_u(I,j) = Kv_rho_ice * mass_eff - enddo ; enddo - do i=isd,ied ; do J=jsd,jed-1 - mass_ice = min(forces%p_surf_full(i,j), forces%p_surf_full(i,j+1)) * I_GEarth - mass_eff = 0.0 - if (mass_ice > CS%rigid_sea_ice_mass) then - mass_eff = (mass_ice - CS%rigid_sea_ice_mass) **2 / & - (mass_ice + CS%rigid_sea_ice_mass) - endif - forces%rigidity_ice_v(i,J) = Kv_rho_ice * mass_eff - enddo ; enddo - endif - - if (CS%allow_flux_adjustments) then - ! Apply adjustments to fluxes - call apply_flux_adjustments(G, CS, Time, forces, fluxes) - endif - - ! Allow for user-written code to alter fluxes after all the above - call user_alter_forcing(state, fluxes, Time, G, CS%urf_CS) - - call cpu_clock_end(id_clock_forcing) - -end subroutine ocn_import - -!> Adds flux adjustments obtained via data_override -!! Component name is 'OCN' -!! Available adjustments are: -!! - taux_adj (Zonal wind stress delta, positive to the east, in Pa) -!! - tauy_adj (Meridional wind stress delta, positive to the north, in Pa) -subroutine apply_flux_adjustments(G, CS, Time, forces, fluxes) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(surface_forcing_CS), pointer :: CS !< Surface forcing control structure - type(time_type), intent(in) :: Time !< Model time structure - type(mech_forcing), intent(inout) :: forces !< Driving mechanical forces - type(forcing), optional, intent(inout) :: fluxes !< Surface fluxes structure - - ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tempx_at_h ! Delta to zonal wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points (Pa) - real, dimension(SZI_(G),SZJ_(G)) :: temp_at_h ! Fluxes at h points (W m-2 or kg m-2 s-1) - - integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau - logical :: overrode_x, overrode_y, overrode_h - - isc = G%isc; iec = G%iec - jsc = G%jsc; jec = G%jec - - overrode_h = .false. - call data_override('OCN', 'hflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%heat_added(i,j) = fluxes%heat_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%heat_added, G%Domain) - - overrode_h = .false. - call data_override('OCN', 'sflx_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%salt_flux_added(i,j) = fluxes%salt_flux_added(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%salt_flux_added, G%Domain) - overrode_h = .false. - - call data_override('OCN', 'prcme_adj', temp_at_h(isc:iec,jsc:jec), Time, override=overrode_h) - - if (overrode_h) then - do j=G%jsc,G%jec ; do i=G%isc,G%iec - fluxes%vprec(i,j) = fluxes%vprec(i,j) + temp_at_h(i,j)* G%mask2dT(i,j) - enddo; enddo - endif - - call pass_var(fluxes%vprec, G%Domain) - - - tempx_at_h(:,:) = 0.0 ; tempy_at_h(:,:) = 0.0 - ! Either reads data or leaves contents unchanged - overrode_x = .false. ; overrode_y = .false. - call data_override('OCN', 'taux_adj', tempx_at_h(isc:iec,jsc:jec), Time, override=overrode_x) - call data_override('OCN', 'tauy_adj', tempy_at_h(isc:iec,jsc:jec), Time, override=overrode_y) - - if (overrode_x .or. overrode_y) then - if (.not. (overrode_x .and. overrode_y)) call MOM_error(FATAL,"apply_flux_adjustments: "//& - "Both taux_adj and tauy_adj must be specified, or neither, in data_table") - - ! Rotate winds - call pass_vector(tempx_at_h, tempy_at_h, G%Domain, To_All, AGRID) - do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - dLonDx = G%geoLonCu(I,j) - G%geoLonCu(I-1,j) - dLonDy = G%geoLonCv(i,J) - G%geoLonCv(i,J-1) - rDlon = sqrt( dLonDx * dLonDx + dLonDy * dLonDy ) - if (rDlon > 0.) rDlon = 1. / rDlon - cosA = dLonDx * rDlon - sinA = dLonDy * rDlon - zonal_tau = tempx_at_h(i,j) - merid_tau = tempy_at_h(i,j) - tempx_at_h(i,j) = cosA * zonal_tau - sinA * merid_tau - tempy_at_h(i,j) = sinA * zonal_tau + cosA * merid_tau - enddo ; enddo - - ! Average to C-grid locations - do j=G%jsc,G%jec ; do I=G%isc-1,G%iec - forces%taux(I,j) = forces%taux(I,j) + 0.5 * ( tempx_at_h(i,j) + tempx_at_h(i+1,j) ) - enddo ; enddo - - do J=G%jsc-1,G%jec ; do i=G%isc,G%iec - forces%tauy(i,J) = forces%tauy(i,J) + 0.5 * ( tempy_at_h(i,j) + tempy_at_h(i,j+1) ) - enddo ; enddo - endif ! overrode_x .or. overrode_y - -end subroutine apply_flux_adjustments +!======================================================================= !> Finalizes MOM6 !! @@ -2426,22 +567,7 @@ subroutine ocn_final_mct( EClock, cdata_o, x2o_o, o2x_o) end subroutine ocn_final_mct -!> Terminates the model run, saving the ocean state in a -!! restart file and deallocating any data associated with the ocean. -subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time) - type(ocean_public_type), intent(inout) :: Ocean_sfc !< An ocean_public_type structure that is to be - !! deallocated upon termination. - type(ocean_state_type), pointer :: Ocean_state!< pointer to the structure containing the internal - ! !! ocean state to be deallocated upon termination. - type(time_type), intent(in) :: Time !< The model time, used for writing restarts. - - call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) - ! print time stats - call MOM_infra_end - call MOM_end(Ocean_state%MOM_CSp) - if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) - -end subroutine ocean_model_end +!======================================================================= !> Sets mct global segment maps for the MOM decomposition. !! @@ -2451,17 +577,18 @@ subroutine ocn_SetGSMap_mct(mpicom_ocn, MOM_MCT_ID, gsMap_ocn, gsMap3d_ocn) integer, intent(in) :: MOM_MCT_ID !< MCT component ID type(mct_gsMap), intent(inout) :: gsMap_ocn !< MCT global segment map for 2d data type(mct_gsMap), intent(inout) :: gsMap3d_ocn !< MCT global segment map for 3d data + ! Local variables - integer :: lsize !< Local size of indirect indexing array - integer :: i, j, k !< Local indices - integer :: ni, nj !< Declared sizes of h-point arrays - integer :: ig, jg !< Global indices + integer :: lsize !< Local size of indirect indexing array + integer :: i, j, k !< Local indices + integer :: ni, nj !< Declared sizes of h-point arrays + integer :: ig, jg !< Global indices type(ocean_grid_type), pointer :: grid => NULL() !< A pointer to a grid structure integer, allocatable :: gindex(:) !< Indirect indices grid => glb%grid ! for convenience if (.not. associated(grid)) call MOM_error(FATAL, 'ocn_comp_mct.F90, ocn_SetGSMap_mct():' // & - 'grid returned from get_state_pointers() was not associated!') + 'grid is not associated!') ! Size of computational domain lsize = ( grid%iec - grid%isc + 1 ) * ( grid%jec - grid%jsc + 1 ) @@ -2490,6 +617,8 @@ subroutine ocn_SetGSMap_mct(mpicom_ocn, MOM_MCT_ID, gsMap_ocn, gsMap3d_ocn) end subroutine ocn_SetGSMap_mct +!======================================================================= + !> Sets MCT global segment maps for the MOM6 decomposition subroutine ocn_domain_mct( lsize, gsMap_ocn, dom_ocn) integer , intent(in) :: lsize !< Size of attr. vector @@ -2507,8 +636,7 @@ subroutine ocn_domain_mct( lsize, gsMap_ocn, dom_ocn) grid => glb%grid ! for convenience ! set coords to lat and lon, and areas to rad^2 - call mct_gGrid_init(GGrid=dom_ocn, CoordChars=trim(seq_flds_dom_coord), & - OtherChars=trim(seq_flds_dom_other), lsize=lsize ) + call mct_gGrid_init(GGrid=dom_ocn, CoordChars='lat:lon:hgt', OtherChars='area:aream:mask:frac', lsize=lsize ) call mct_avect_zero(dom_ocn%data) allocate(data(lsize)) @@ -2571,6 +699,8 @@ subroutine ocn_domain_mct( lsize, gsMap_ocn, dom_ocn) end subroutine ocn_domain_mct +!======================================================================= + !> Returns the CESM run type character(32) function get_runtype() character(len=32) :: starttype !< infodata start type @@ -2591,6 +721,27 @@ end subroutine ocn_domain_mct end function +!======================================================================= + +!> It has to be separate from the ocean_initialization call because the coupler +!! module allocates the space for some of these variables. +subroutine ocean_model_init_sfc(OS, Ocean_sfc) + type(ocean_state_type), pointer :: OS + type(ocean_public_type), intent(inout) :: Ocean_sfc + + integer :: is, ie, js, je + + is = OS%grid%isc ; ie = OS%grid%iec ; js = OS%grid%jsc ; je = OS%grid%jec + call coupler_type_spawn(Ocean_sfc%fields, OS%sfc_state%tr_fields, & + (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + + call extract_surface_state(OS%MOM_CSp, OS%sfc_state) + + call convert_state_to_ocean_type(OS%sfc_state, Ocean_sfc, OS%grid) + +end subroutine ocean_model_init_sfc + +!======================================================================= !> \namespace ocn_comp_mct !! diff --git a/config_src/mct_driver/ocn_cpl_indices.F90 b/config_src/mct_driver/ocn_cpl_indices.F90 new file mode 100644 index 0000000000..4bd9c1f383 --- /dev/null +++ b/config_src/mct_driver/ocn_cpl_indices.F90 @@ -0,0 +1,192 @@ +module ocn_cpl_indices + + use mct_mod, only: mct_avect_init, mct_avect_indexra, mct_aVect_clean, mct_aVect + use seq_flds_mod, only: ice_ncat, seq_flds_i2o_per_cat + use seq_flds_mod, only: seq_flds_x2o_fields, seq_flds_o2x_fields + + implicit none ; public + + !> Structure with indices needed for MCT attribute vectors + type cpl_indices_type + ! ocean to coupler + integer :: o2x_So_t !< Surface potential temperature (deg C) + integer :: o2x_So_u !< Surface zonal velocity (m/s) + integer :: o2x_So_v !< Surface meridional velocity (m/s) + integer :: o2x_So_s !< Surface salinity (PSU) + integer :: o2x_So_dhdx !< Zonal slope in the sea surface height + integer :: o2x_So_dhdy !< Meridional lope in the sea surface height + integer :: o2x_So_bldepth !< Boundary layer depth (m) + integer :: o2x_Fioo_q !< Heat flux? + integer :: o2x_Faoo_fco2_ocn !< CO2 flux + integer :: o2x_Faoo_fdms_ocn !< DMS flux + + ! coupler to ocean + integer :: x2o_Si_ifrac !< Fractional ice wrt ocean + integer :: x2o_So_duu10n !< 10m wind speed squared (m^2/s^2) + integer :: x2o_Sa_pslv !< Sea-level pressure (Pa) + integer :: x2o_Sa_co2prog !< Bottom atm level prognostic CO2 + integer :: x2o_Sa_co2diag !< Bottom atm level diagnostic CO2 + integer :: x2o_Sw_lamult !< Wave model langmuir multiplier + integer :: x2o_Sw_ustokes !< Surface Stokes drift, x-component + integer :: x2o_Sw_vstokes !< Surface Stokes drift, y-component + integer :: x2o_Foxx_taux !< Zonal wind stress (W/m2) + integer :: x2o_Foxx_tauy !< Meridonal wind stress (W/m2) + integer :: x2o_Foxx_swnet !< Net short-wave heat flux (W/m2) + integer :: x2o_Foxx_sen !< Sensible heat flux (W/m2) + integer :: x2o_Foxx_lat !< Latent heat flux (W/m2) + integer :: x2o_Foxx_lwup !< Longwave radiation, up (W/m2) + integer :: x2o_Faxa_lwdn !< Longwave radiation, down (W/m2) + integer :: x2o_Faxa_swvdr !< Visible, direct shortwave (W/m2) + integer :: x2o_Faxa_swvdf !< Visible, diffuse shortwave (W/m2) + integer :: x2o_Faxa_swndr !< near-IR, direct shortwave (W/m2) + integer :: x2o_Faxa_swndf !< near-IR, direct shortwave (W/m2) + integer :: x2o_Fioi_melth !< Heat flux from snow & ice melt (W/m2) + integer :: x2o_Fioi_meltw !< Snow melt flux (kg/m2/s) + integer :: x2o_Fioi_bcpho !< Black Carbon hydrophobic release from sea ice component + integer :: x2o_Fioi_bcphi !< Black Carbon hydrophilic release from sea ice component + integer :: x2o_Fioi_flxdst !< Dust release from sea ice component + integer :: x2o_Fioi_salt !< Salt flux (kg(salt)/m2/s) + integer :: x2o_Foxx_evap !< Evaporation flux (kg/m2/s) + integer :: x2o_Faxa_prec !< Total precipitation flux (kg/m2/s) + integer :: x2o_Faxa_snow !< Water flux due to snow (kg/m2/s) + integer :: x2o_Faxa_rain !< Water flux due to rain (kg/m2/s) + integer :: x2o_Faxa_bcphidry !< Black Carbon hydrophilic dry deposition + integer :: x2o_Faxa_bcphodry !< Black Carbon hydrophobic dry deposition + integer :: x2o_Faxa_bcphiwet !< Black Carbon hydrophilic wet deposition + integer :: x2o_Faxa_ocphidry !< Organic Carbon hydrophilic dry deposition + integer :: x2o_Faxa_ocphodry !< Organic Carbon hydrophobic dry deposition + integer :: x2o_Faxa_ocphiwet !< Organic Carbon hydrophilic dry deposition + integer :: x2o_Faxa_dstwet1 !< Size 1 dust -- wet deposition + integer :: x2o_Faxa_dstwet2 !< Size 2 dust -- wet deposition + integer :: x2o_Faxa_dstwet3 !< Size 3 dust -- wet deposition + integer :: x2o_Faxa_dstwet4 !< Size 4 dust -- wet deposition + integer :: x2o_Faxa_dstdry1 !< Size 1 dust -- dry deposition + integer :: x2o_Faxa_dstdry2 !< Size 2 dust -- dry deposition + integer :: x2o_Faxa_dstdry3 !< Size 3 dust -- dry deposition + integer :: x2o_Faxa_dstdry4 !< Size 4 dust -- dry deposition + integer :: x2o_Foxx_rofl !< River runoff flux (kg/m2/s) + integer :: x2o_Foxx_rofi !< Ice runoff flux (kg/m2/s) + + ! optional per thickness category fields + integer, dimension(:), allocatable :: x2o_frac_col !< Fraction of ocean cell, per column + integer, dimension(:), allocatable :: x2o_fracr_col !< Fraction of ocean cell used in radiation computations, + !! per column + integer, dimension(:), allocatable :: x2o_qsw_fracr_col !< qsw * fracr, per column + end type cpl_indices_type + + public :: cpl_indices_init + +!======================================================================= +contains +!======================================================================= + + !> Determines attribute vector indices + subroutine cpl_indices_init(ind) + type(cpl_indices_type), intent(inout) :: ind !< Structure with coupler indices and vectors + + ! Local Variables + type(mct_aVect) :: o2x !< Array with ocean to coupler data + type(mct_aVect) :: x2o !< Array with coupler to ocean data + integer :: ncat !< Thickness category index + character(len=2) :: cncat !< Character version of ncat + integer :: ncol !< Column index + integer :: mcog_ncols !< Number of ice thickness categories? + integer :: lmcog_flds_sent !< Used to convert per thickness category fields? + + ! create temporary attribute vectors + call mct_aVect_init(x2o, rList=seq_flds_x2o_fields, lsize=1) + call mct_aVect_init(o2x, rList=seq_flds_o2x_fields, lsize=1) + + ! ocean to coupler + ind%o2x_So_t = mct_avect_indexra(o2x,'So_t') + ind%o2x_So_u = mct_avect_indexra(o2x,'So_u') + ind%o2x_So_v = mct_avect_indexra(o2x,'So_v') + ind%o2x_So_s = mct_avect_indexra(o2x,'So_s') + ind%o2x_So_dhdx = mct_avect_indexra(o2x,'So_dhdx') + ind%o2x_So_dhdy = mct_avect_indexra(o2x,'So_dhdy') + ind%o2x_So_bldepth = mct_avect_indexra(o2x,'So_bldepth') + ind%o2x_Fioo_q = mct_avect_indexra(o2x,'Fioo_q') + ind%o2x_Faoo_fco2_ocn = mct_avect_indexra(o2x,'Faoo_fco2_ocn',perrWith='quiet') + ind%o2x_Faoo_fdms_ocn = mct_avect_indexra(o2x,'Faoo_fdms_ocn',perrWith='quiet') + + ! coupler to ocean + ind%x2o_Si_ifrac = mct_avect_indexra(x2o,'Si_ifrac') + ind%x2o_Sa_pslv = mct_avect_indexra(x2o,'Sa_pslv') + ind%x2o_So_duu10n = mct_avect_indexra(x2o,'So_duu10n') + ind%x2o_Sw_lamult = mct_avect_indexra(x2o,'Sw_lamult') + ind%x2o_Sw_ustokes = mct_avect_indexra(x2o,'Sw_ustokes') + ind%x2o_Sw_vstokes = mct_avect_indexra(x2o,'Sw_vstokes') + ind%x2o_Foxx_tauy = mct_avect_indexra(x2o,'Foxx_tauy') + ind%x2o_Foxx_taux = mct_avect_indexra(x2o,'Foxx_taux') + ind%x2o_Foxx_swnet = mct_avect_indexra(x2o,'Foxx_swnet') + ind%x2o_Foxx_lat = mct_avect_indexra(x2o,'Foxx_lat') + ind%x2o_Foxx_sen = mct_avect_indexra(x2o,'Foxx_sen') + ind%x2o_Foxx_lwup = mct_avect_indexra(x2o,'Foxx_lwup') + ind%x2o_Faxa_lwdn = mct_avect_indexra(x2o,'Faxa_lwdn') + ind%x2o_Faxa_swvdr = mct_avect_indexra(x2o,'Faxa_swvdr',perrWith='quiet') + ind%x2o_Faxa_swvdf = mct_avect_indexra(x2o,'Faxa_swvdf',perrWith='quiet') + ind%x2o_Faxa_swndr = mct_avect_indexra(x2o,'Faxa_swndr',perrWith='quiet') + ind%x2o_Faxa_swndf = mct_avect_indexra(x2o,'Faxa_swndf',perrWith='quiet') + ind%x2o_Fioi_melth = mct_avect_indexra(x2o,'Fioi_melth') + ind%x2o_Fioi_meltw = mct_avect_indexra(x2o,'Fioi_meltw') + ind%x2o_Fioi_salt = mct_avect_indexra(x2o,'Fioi_salt') + ind%x2o_Fioi_bcpho = mct_avect_indexra(x2o,'Fioi_bcpho') + ind%x2o_Fioi_bcphi = mct_avect_indexra(x2o,'Fioi_bcphi') + ind%x2o_Fioi_flxdst = mct_avect_indexra(x2o,'Fioi_flxdst') + ind%x2o_Faxa_prec = mct_avect_indexra(x2o,'Faxa_prec') + ind%x2o_Faxa_snow = mct_avect_indexra(x2o,'Faxa_snow') + ind%x2o_Faxa_rain = mct_avect_indexra(x2o,'Faxa_rain') + ind%x2o_Foxx_evap = mct_avect_indexra(x2o,'Foxx_evap') + ind%x2o_Foxx_rofl = mct_avect_indexra(x2o,'Foxx_rofl') + ind%x2o_Foxx_rofi = mct_avect_indexra(x2o,'Foxx_rofi') + ind%x2o_Faxa_bcphidry = mct_avect_indexra(x2o,'Faxa_bcphidry') + ind%x2o_Faxa_bcphodry = mct_avect_indexra(x2o,'Faxa_bcphodry') + ind%x2o_Faxa_bcphiwet = mct_avect_indexra(x2o,'Faxa_bcphiwet') + ind%x2o_Faxa_ocphidry = mct_avect_indexra(x2o,'Faxa_ocphidry') + ind%x2o_Faxa_ocphodry = mct_avect_indexra(x2o,'Faxa_ocphodry') + ind%x2o_Faxa_ocphiwet = mct_avect_indexra(x2o,'Faxa_ocphiwet') + ind%x2o_Faxa_dstdry1 = mct_avect_indexra(x2o,'Faxa_dstdry1') + ind%x2o_Faxa_dstdry2 = mct_avect_indexra(x2o,'Faxa_dstdry2') + ind%x2o_Faxa_dstdry3 = mct_avect_indexra(x2o,'Faxa_dstdry3') + ind%x2o_Faxa_dstdry4 = mct_avect_indexra(x2o,'Faxa_dstdry4') + ind%x2o_Faxa_dstwet1 = mct_avect_indexra(x2o,'Faxa_dstwet1') + ind%x2o_Faxa_dstwet2 = mct_avect_indexra(x2o,'Faxa_dstwet2') + ind%x2o_Faxa_dstwet3 = mct_avect_indexra(x2o,'Faxa_dstwet3') + ind%x2o_Faxa_dstwet4 = mct_avect_indexra(x2o,'Faxa_dstwet4') + ind%x2o_Sa_co2prog = mct_avect_indexra(x2o,'Sa_co2prog',perrWith='quiet') + ind%x2o_Sa_co2diag = mct_avect_indexra(x2o,'Sa_co2diag',perrWith='quiet') + + ! optional per thickness category fields + ! convert cpl indices to mcog column indices + ! this implementation only handles columns due to ice thickness categories + lmcog_flds_sent = seq_flds_i2o_per_cat + + if (seq_flds_i2o_per_cat) then + mcog_ncols = ice_ncat+1 + allocate(ind%x2o_frac_col(mcog_ncols)) + allocate(ind%x2o_fracr_col(mcog_ncols)) + allocate(ind%x2o_qsw_fracr_col(mcog_ncols)) + ncol = 1 + ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Sf_afrac') + ind%x2o_fracr_col(ncol) = mct_avect_indexra(x2o,'Sf_afracr') + 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) + enddo + else + mcog_ncols = 1 + endif + + call mct_aVect_clean(x2o) + call mct_aVect_clean(o2x) + + end subroutine cpl_indices_init + +!======================================================================= + +end module ocn_cpl_indices diff --git a/config_src/solo_driver/MESO_surface_forcing.F90 b/config_src/solo_driver/MESO_surface_forcing.F90 index 86dd23eb06..578aa68a2a 100644 --- a/config_src/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/solo_driver/MESO_surface_forcing.F90 @@ -44,7 +44,7 @@ module MESO_surface_forcing !* * !********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -97,11 +97,13 @@ module MESO_surface_forcing contains +!### This subroutine sets zero surface wind stresses, but it is not even +!### used by the MESO experimeents. This subroutine can be deleted. -RWH subroutine MESO_wind_forcing(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by a previous !! call to MESO_surface_forcing_init @@ -160,15 +162,18 @@ subroutine MESO_wind_forcing(sfc_state, forces, day, G, CS) end subroutine MESO_wind_forcing +!> This subroutine sets up the MESO buoyancy forcing, which uses control-theory style +!! specification restorative buoyancy fluxes at large scales. subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(MESO_surface_forcing_CS), pointer :: CS + type(MESO_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned by + !! a previous call to MESO_surface_forcing_init ! This subroutine specifies the current surface fluxes of buoyancy or ! temperature and fresh water. It may also be modified to add @@ -215,30 +220,30 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%fprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lrunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%frunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%vprec, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%heat_content_lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_content_lprec, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. if (CS%restorebuoy .and. first_call) then !### .or. associated(CS%ctrl_forcing_CSp)) then - call alloc_if_needed(CS%T_Restore, isd, ied, jsd, jed) - call alloc_if_needed(CS%S_Restore, isd, ied, jsd, jed) - call alloc_if_needed(CS%Heat, isd, ied, jsd, jed) - call alloc_if_needed(CS%PmE, isd, ied, jsd, jed) - call alloc_if_needed(CS%Solar, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%T_Restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%S_Restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%Heat, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%PmE, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%Solar, isd, ied, jsd, jed) call MOM_read_data(trim(CS%inputdir)//trim(CS%SSTrestore_file), "SST", & CS%T_Restore(:,:), G%Domain) @@ -281,7 +286,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_added, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & @@ -323,24 +328,16 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine MESO_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.ASSOCIATED(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> Initialize the MESO surface forcing module subroutine MESO_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(MESO_surface_forcing_CS), pointer :: CS + + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output + type(MESO_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module + ! Arguments: Time - The current model time. ! (in) G - The ocean's grid structure. ! (in) param_file - A structure indicating the open file to parse for diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 17fa4167c9..61c3f4a509 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -63,11 +63,15 @@ program MOM_main use ensemble_manager_mod, only : ensemble_manager_init, get_ensemble_size use ensemble_manager_mod, only : ensemble_pelist_setup use mpp_mod, only : set_current_pelist => mpp_set_current_pelist + use time_interp_external_mod, only : time_interp_external_init use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS - use MOM_ice_shelf, only : shelf_calc_flux, ice_shelf_save_restart + use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart ! , add_shelf_flux_forcing, add_shelf_flux_IOB + use MOM_wave_interface, only: wave_parameters_CS, MOM_wave_interface_init + use MOM_wave_interface, only: MOM_wave_interface_init_lite, Update_Surface_Waves + implicit none #include @@ -88,6 +92,9 @@ program MOM_main ! If .true., use the ice shelf model for part of the domain. logical :: use_ice_shelf + ! If .true., use surface wave coupling + logical :: use_waves = .false. + ! This is .true. if incremental restart files may be saved. logical :: permit_incr_restart = .true. @@ -97,7 +104,7 @@ program MOM_main ! simulation does not exceed its CPU time limit. nmax is determined by ! evaluating the CPU time used between successive calls to write_cputime. ! Initially it is set to be very large. - integer :: nmax=2000000000; + integer :: nmax=2000000000 ! A structure containing several relevant directory paths. type(directories) :: dirs @@ -179,6 +186,7 @@ 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() + 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. @@ -238,8 +246,8 @@ program MOM_main endif !$ call omp_set_num_threads(ocean_nthreads) -!$OMP PARALLEL private(adder) !$ base_cpu = get_cpu_affinity() +!$OMP PARALLEL private(adder) !$ if (use_hyper_thread) then !$ if (mod(omp_get_thread_num(),2) == 0) then !$ adder = omp_get_thread_num()/2 @@ -250,7 +258,7 @@ program MOM_main !$ adder = omp_get_thread_num() !$ endif !$ call set_cpu_affinity (base_cpu + adder) -!$ write(6,*) " ocean ", omp_get_num_threads(), get_cpu_affinity(), adder, omp_get_thread_num() +!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() !$ call flush(6) !$OMP END PARALLEL @@ -265,11 +273,11 @@ program MOM_main else calendar = uppercase(calendar) if (calendar(1:6) == 'JULIAN') then ; calendar_type = JULIAN - else if (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN - else if (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP - else if (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS - else if (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR - else if (calendar(1:1) /= ' ') then + elseif (calendar(1:9) == 'GREGORIAN') then ; calendar_type = GREGORIAN + elseif (calendar(1:6) == 'NOLEAP') then ; calendar_type = NOLEAP + elseif (calendar(1:10)=='THIRTY_DAY') then ; calendar_type = THIRTY_DAY_MONTHS + elseif (calendar(1:11)=='NO_CALENDAR') then; calendar_type = NO_CALENDAR + elseif (calendar(1:1) /= ' ') then call MOM_error(FATAL,'MOM_driver: Invalid namelist value '//trim(calendar)//' for calendar') else call MOM_error(FATAL,'MOM_driver: No namelist value for calendar') @@ -285,6 +293,8 @@ program MOM_main Start_time = set_time(0,days=0) endif + call time_interp_external_init + if (sum(date) >= 0) then ! In this case, the segment starts at a time fixed by ocean_solo.res segment_start_time = set_date(date(1),date(2),date(3),date(4),date(5),date(6)) @@ -321,6 +331,14 @@ program MOM_main diag, forces, fluxes) endif + call get_param(param_file,mod_name,"USE_WAVES",Use_Waves,& + "If true, enables surface wave modules.",default=.false.) + if (use_waves) then + call MOM_wave_interface_init(Time,grid,GV,param_file,Waves_CSp,diag) + else + call MOM_wave_interface_init_lite(param_file) + endif + segment_start_time = Time elapsed_time = 0.0 @@ -405,7 +423,8 @@ program MOM_main "the segment run-length can not be set via an elapsed CPU time.", & default=1000) call get_param(param_file, "MOM", "DEBUG", debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call log_param(param_file, mod_name, "ELAPSED TIME AS MASTER", elapsed_time_master) @@ -464,16 +483,18 @@ program MOM_main endif if (use_ice_shelf) then - call shelf_calc_flux(sfc_state, forces, fluxes, Time, dt_forcing, ice_shelf_CSp) -!###IS call add_shelf_flux_forcing(fluxes, ice_shelf_CSp) -!###IS ! With a coupled ice/ocean run, use the following call. -!###IS call add_shelf_flux_IOB(ice_ocean_bdry_type, ice_shelf_CSp) + call shelf_calc_flux(sfc_state, fluxes, Time, dt_forcing, ice_shelf_CSp) + call add_shelf_forces(grid, Ice_shelf_CSp, forces) endif fluxes%fluxes_used = .false. fluxes%dt_buoy_accum = dt_forcing + if (use_waves) then + call Update_Surface_Waves(grid,GV,time,time_step_ocean,waves_csp) + endif + if (ns==1) then - call finish_MOM_initialization(Time, dirs, MOM_CSp, fluxes, restart_CSp) + call finish_MOM_initialization(Time, dirs, MOM_CSp, restart_CSp) endif ! This call steps the model over a time dt_forcing. @@ -481,7 +502,7 @@ program MOM_main if (offline_tracer_mode) then call step_offline(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp) elseif (single_step_call) then - call step_MOM(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp) + call step_MOM(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) else n_max = 1 ; if (dt_forcing > dt) n_max = ceiling(dt_forcing/dt - 0.001) dt_dyn = dt_forcing / real(n_max) @@ -618,7 +639,7 @@ program MOM_main call get_date(Time, yr, mon, day, hr, mins, sec) write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & 'Current model time: year, month, day, hour, minute, second' - end if + endif call close_file(unit) endif diff --git a/config_src/solo_driver/MOM_surface_forcing.F90 b/config_src/solo_driver/MOM_surface_forcing.F90 index 37bcaea17e..38ac1917a8 100644 --- a/config_src/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/solo_driver/MOM_surface_forcing.F90 @@ -213,20 +213,23 @@ module MOM_surface_forcing end type surface_forcing_CS - integer :: id_clock_forcing contains +!> This subroutine calls other subroutines in this file to get surface forcing fields. +!! It also allocates and initializes the fields in the forcing and mech_forcing types +!! the first time it is called. subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day_start - type(time_type), intent(in) :: day_interval + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day_start !< The start time of the fluxes + type(time_type), intent(in) :: day_interval !< Length of time over which these fluxes applied type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine calls other subroutines in this file to get surface forcing fields. ! It also allocates and initializes the fields in the flux type. @@ -370,15 +373,17 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, CS end subroutine set_forcing +!> This subroutine sets the surface wind stresses to constant values subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: tau_x0 - real, intent(in) :: tau_y0 - type(time_type), intent(in) :: day + real, intent(in) :: tau_x0 !< The zonal wind stress in Pa + real, intent(in) :: tau_y0 !< The meridional wind stress in Pa + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! subroutine sets the surface wind stresses to zero @@ -424,13 +429,15 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, CS) end subroutine wind_forcing_const +!> This subroutine sets the surface wind stresses to set up two idealized gyres. subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses according to double gyre. @@ -467,13 +474,15 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, CS) end subroutine wind_forcing_2gyre +!> This subroutine sets the surface wind stresses to set up a single idealized gyre. subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses according to single gyre. @@ -509,23 +518,17 @@ subroutine wind_forcing_1gyre(sfc_state, forces, day, G, CS) end subroutine wind_forcing_1gyre +!> This subroutine sets the surface wind stresses to set up idealized gyres. subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses according to gyres. - -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - real :: PI, y integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -561,13 +564,15 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, CS) end subroutine wind_forcing_gyres +! This subroutine sets the surface wind stresses from input files. subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses. @@ -599,16 +604,16 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) time_lev_daily = days - 365*floor(real(days) / 365.0) if (time_lev_daily < 31) then ; time_lev_monthly = 0 - else if (time_lev_daily < 59) then ; time_lev_monthly = 1 - else if (time_lev_daily < 90) then ; time_lev_monthly = 2 - else if (time_lev_daily < 120) then ; time_lev_monthly = 3 - else if (time_lev_daily < 151) then ; time_lev_monthly = 4 - else if (time_lev_daily < 181) then ; time_lev_monthly = 5 - else if (time_lev_daily < 212) then ; time_lev_monthly = 6 - else if (time_lev_daily < 243) then ; time_lev_monthly = 7 - else if (time_lev_daily < 273) then ; time_lev_monthly = 8 - else if (time_lev_daily < 304) then ; time_lev_monthly = 9 - else if (time_lev_daily < 334) then ; time_lev_monthly = 10 + elseif (time_lev_daily < 59) then ; time_lev_monthly = 1 + elseif (time_lev_daily < 90) then ; time_lev_monthly = 2 + elseif (time_lev_daily < 120) then ; time_lev_monthly = 3 + elseif (time_lev_daily < 151) then ; time_lev_monthly = 4 + elseif (time_lev_daily < 181) then ; time_lev_monthly = 5 + elseif (time_lev_daily < 212) then ; time_lev_monthly = 6 + elseif (time_lev_daily < 243) then ; time_lev_monthly = 7 + elseif (time_lev_daily < 273) then ; time_lev_monthly = 8 + elseif (time_lev_daily < 304) then ; time_lev_monthly = 9 + elseif (time_lev_daily < 334) then ; time_lev_monthly = 10 else ; time_lev_monthly = 11 endif @@ -720,13 +725,15 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, CS) end subroutine wind_forcing_from_file +! This subroutine sets the surface wind stresses via the data override facility. subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine sets the surface wind stresses ! Arguments: @@ -791,29 +798,23 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, CS) end subroutine wind_forcing_by_data_override +!> This subroutine specifies zero surface bouyancy fluxes from input files. subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add ! surface fluxes of user provided tracers. ! This case has surface buoyancy forcing from input files. -! Arguments: -! state = structure describing ocean surface state -! (out) fluxes = structure with pointers to forcing fields; unused have NULL ptrs -! (in) day = time of the fluxes -! (in) dt = amount of time over which the fluxes apply -! (in) G = ocean grid structure -! (in) CS = pointer to control struct returned by previous surface_forcing_init call - real, dimension(SZI_(G),SZJ_(G)) :: & temp, & ! A 2-d temporary work array with various units. SST_anom, & ! Instantaneous sea surface temperature anomalies from a @@ -847,16 +848,16 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) time_lev_daily = days - 365*floor(real(days) / 365.0) if (time_lev_daily < 31) then ; time_lev_monthly = 0 - else if (time_lev_daily < 59) then ; time_lev_monthly = 1 - else if (time_lev_daily < 90) then ; time_lev_monthly = 2 - else if (time_lev_daily < 120) then ; time_lev_monthly = 3 - else if (time_lev_daily < 151) then ; time_lev_monthly = 4 - else if (time_lev_daily < 181) then ; time_lev_monthly = 5 - else if (time_lev_daily < 212) then ; time_lev_monthly = 6 - else if (time_lev_daily < 243) then ; time_lev_monthly = 7 - else if (time_lev_daily < 273) then ; time_lev_monthly = 8 - else if (time_lev_daily < 304) then ; time_lev_monthly = 9 - else if (time_lev_daily < 334) then ; time_lev_monthly = 10 + elseif (time_lev_daily < 59) then ; time_lev_monthly = 1 + elseif (time_lev_daily < 90) then ; time_lev_monthly = 2 + elseif (time_lev_daily < 120) then ; time_lev_monthly = 3 + elseif (time_lev_daily < 151) then ; time_lev_monthly = 4 + elseif (time_lev_daily < 181) then ; time_lev_monthly = 5 + elseif (time_lev_daily < 212) then ; time_lev_monthly = 6 + elseif (time_lev_daily < 243) then ; time_lev_monthly = 7 + elseif (time_lev_daily < 273) then ; time_lev_monthly = 8 + elseif (time_lev_daily < 304) then ; time_lev_monthly = 9 + elseif (time_lev_daily < 334) then ; time_lev_monthly = 10 else ; time_lev_monthly = 11 endif @@ -1080,16 +1081,17 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_from_files") end subroutine buoyancy_forcing_from_files - +!> This subroutine specifies zero surface bouyancy fluxes from data over-ride. subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS) - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day - real, intent(in) :: dt !< The amount of time over which - !! the fluxes apply, in s - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes + real, intent(in) :: dt !< The amount of time over which + !! the fluxes apply, in s + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add @@ -1153,7 +1155,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS ! but evap is normally a positive quantity in the files fluxes%latent(i,j) = CS%latent_heat_vapor*fluxes%evap(i,j) fluxes%latent_evap_diag(i,j) = fluxes%latent(i,j) - enddo; enddo + enddo ; enddo call data_override('OCN', 'sens', fluxes%sens(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) @@ -1162,7 +1164,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS do j=js,je ; do i=is,ie fluxes%sens(i,j) = -fluxes%sens(i,j) ! Normal convention is positive into the ocean ! but sensible is normally a positive quantity in the files - enddo; enddo + enddo ; enddo call data_override('OCN', 'sw', fluxes%sw(:,:), day, & is_in=is_in, ie_in=ie_in, js_in=js_in, je_in=je_in) @@ -1258,16 +1260,17 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, CS call callTree_leave("buoyancy_forcing_from_data_override") end subroutine buoyancy_forcing_from_data_override - +!> This subroutine specifies zero surface bouyancy fluxes subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add @@ -1313,15 +1316,17 @@ subroutine buoyancy_forcing_zero(sfc_state, fluxes, day, dt, G, CS) end subroutine buoyancy_forcing_zero +!> This subroutine sets up spatially and temporally constant surface heat fluxes. subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add @@ -1366,15 +1371,18 @@ subroutine buoyancy_forcing_const(sfc_state, fluxes, day, dt, G, CS) end subroutine buoyancy_forcing_const +!> This subroutine sets surface fluxes of heat and salinity by restoring to temperature and +!! saliinty profiles that vary linearly with latitude. subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call ! This subroutine specifies the current surface fluxes of buoyancy ! temperature and fresh water. It may also be modified to add @@ -1456,15 +1464,18 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, CS) call callTree_leave("buoyancy_forcing_linear") end subroutine buoyancy_forcing_linear - +!> Save a restart file for the forcing fields subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) - type(surface_forcing_CS), pointer :: CS + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(time_type), intent(in) :: Time - character(len=*), intent(in) :: directory - logical, optional, intent(in) :: time_stamped - character(len=*), optional, intent(in) :: filename_suffix + type(time_type), intent(in) :: Time !< model time at this call; needed for mpp_write calls + character(len=*), intent(in) :: directory !< directory into which to write these restart files + logical, optional, intent(in) :: time_stamped !< If true, the restart file names + !! include a unique time stamp; the default is false. + character(len=*), optional, intent(in) :: filename_suffix !< optional suffix (e.g., a time-stamp) + !! to append to the restart fname ! Arguments: ! CS = pointer to control structure from previous surface_forcing_init call @@ -1482,13 +1493,14 @@ subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & end subroutine forcing_save_restart - +!> Initialize the surface forcing module subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) - type(time_type), intent(in) :: Time + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag - type(surface_forcing_CS), pointer :: CS + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call type(tracer_flow_control_CS), pointer :: tracer_flow_CSp ! Arguments: @@ -1891,9 +1903,11 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, tracer_flow_CSp) end subroutine surface_forcing_init +!> Deallocate memory associated with the surface forcing module subroutine surface_forcing_end(CS, fluxes) - type(surface_forcing_CS), pointer :: CS - type(forcing), optional, intent(inout) :: fluxes + type(surface_forcing_CS), pointer :: CS !< pointer to control struct returned by + !! a previous surface_forcing_init call + type(forcing), optional, intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields ! Arguments: CS - A pointer to the control structure returned by a previous ! call to surface_forcing_init, it will be deallocated here. ! (inout) fluxes - A structure containing pointers to any possible diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index 9b020d4fc1..55476f9051 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -4,7 +4,7 @@ module Neverland_surface_forcing ! This file is part of MOM6. See LICENSE.md for the license. use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type @@ -73,23 +73,23 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, CS) ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. - PI = 4.0*atan(1.0) - forces%taux(:,:) = 0.0 - tau_max = 0.2 - off = 0.02 + PI = 4.0*atan(1.0) + forces%taux(:,:) = 0.0 + tau_max = 0.2 + off = 0.02 do j=js,je ; do I=is-1,Ieq -! x=(G%geoLonT(i,j)-G%west_lon)/G%len_lon - y=(G%geoLatT(i,j)-G%south_lat)/G%len_lat -! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 +! x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat +! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 - if (y.le.0.29) then - forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) + if (y <= 0.29) then + forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) endif - if (y.gt.0.29 .and. y.le.(0.8-off)) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) + if ((y > 0.29) .and. (y <= (0.8-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) endif - if (y.gt.(0.8-off) .and. y.le.(1-off) ) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) + if ((y > (0.8-off)) .and. (y <= (1-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) endif enddo ; enddo @@ -160,13 +160,13 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) "Temperature and salinity mode not coded!" ) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif ! MODIFY THE CODE IN THE FOLLOWING LOOPS TO SET THE BUOYANCY FORCING TERMS. if (CS%restorebuoy .and. CS%first_call) then - call alloc_if_needed(CS%buoy_restore, isd, ied, jsd, jed) + call safe_alloc_ptr(CS%buoy_restore, isd, ied, jsd, jed) CS%first_call = .false. ! Set CS%buoy_restore(i,j) here endif @@ -205,18 +205,6 @@ subroutine Neverland_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine Neverland_buoyancy_forcing -!> If ptr is not associated, this routine allocates it with the given size -!! and zeros out its contents. This is equivalent to safe_alloc_ptr in -!! MOM_diag_mediator, but is here so as to be completely transparent. -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.ASSOCIATED(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - !> Initializes the Neverland control structure. subroutine Neverland_surface_forcing_init(Time, G, param_file, diag, CS) type(time_type), intent(in) :: Time !< The current model time. diff --git a/config_src/solo_driver/atmos_ocean_fluxes.F90 b/config_src/solo_driver/atmos_ocean_fluxes.F90 index 66b2463ae7..5494954398 100644 --- a/config_src/solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/solo_driver/atmos_ocean_fluxes.F90 @@ -10,21 +10,23 @@ module atmos_ocean_fluxes_mod contains +!> This subroutine duplicates an interface used by the FMS coupler, but only +!! returns a value of -1. None of the arguments are used for anything. function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, & param, flag, ice_restart_file, ocean_restart_file, & units, caller, verbosity) result (coupler_index) - character(len=*), intent(in) :: name - character(len=*), intent(in) :: flux_type - character(len=*), intent(in) :: implementation - integer, intent(in), optional :: atm_tr_index - real, intent(in), dimension(:), optional :: param - logical, intent(in), dimension(:), optional :: flag - character(len=*), intent(in), optional :: ice_restart_file - character(len=*), intent(in), optional :: ocean_restart_file - character(len=*), intent(in), optional :: units - character(len=*), intent(in), optional :: caller - integer, intent(in), optional :: verbosity + character(len=*), intent(in) :: name !< An unused argument + character(len=*), intent(in) :: flux_type !< An unused argument + character(len=*), intent(in) :: implementation !< An unused argument + integer, optional, intent(in) :: atm_tr_index !< An unused argument + real, dimension(:), optional, intent(in) :: param !< An unused argument + logical, dimension(:), optional, intent(in) :: flag !< An unused argument + character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument + character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument + character(len=*), optional, intent(in) :: units !< An unused argument + character(len=*), optional, intent(in) :: caller !< An unused argument + integer, optional, intent(in) :: verbosity !< An unused argument ! None of these arguments are used for anything. diff --git a/config_src/solo_driver/coupler_types.F90 b/config_src/solo_driver/coupler_types.F90 index 819eac6de7..99a74e085c 100644 --- a/config_src/solo_driver/coupler_types.F90 +++ b/config_src/solo_driver/coupler_types.F90 @@ -68,7 +68,8 @@ module coupler_types_mod type, public :: coupler_3d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_3d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type @@ -115,7 +116,8 @@ module coupler_types_mod type, public :: coupler_2d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_2d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized integer :: isd, isc, iec, ied !< The i-direction data and computational domain index ranges for this type integer :: jsd, jsc, jec, jed !< The j-direction data and computational domain index ranges for this type @@ -156,7 +158,8 @@ module coupler_types_mod type, public :: coupler_1d_bc_type integer :: num_bcs = 0 !< The number of boundary condition fields - type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary condition fields + type(coupler_1d_field_type), dimension(:), pointer :: bc => NULL() !< A pointer to the array of boundary + !! condition fields logical :: set = .false. !< If true, this type has been initialized end type coupler_1d_bc_type @@ -291,10 +294,11 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_1d_2d):' @@ -310,7 +314,7 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_1d_2d @@ -340,10 +344,11 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then + !! don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_1d_3d):' @@ -360,7 +365,7 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_1d_3d @@ -383,10 +388,11 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_2d_2d):' @@ -402,7 +408,7 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_2d_2d @@ -432,10 +438,11 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_2d_3d):' @@ -452,7 +459,7 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_2d_3d @@ -475,10 +482,11 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & integer, intent(in) :: ie !< upper bound of first dimension integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_3d_2d):' @@ -494,7 +502,7 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_3d_2d @@ -524,10 +532,11 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & integer, intent(in) :: js !< lower bound of second dimension integer, intent(in) :: je !< upper bound of second dimension integer, intent(in) :: kd !< third dimension - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field - character(len=*), intent(in), optional :: suffix !< optional suffix to make the name identifier unique + character(len=*), optional, intent(in) :: suffix !< optional suffix to make the name identifier unique character(len=256), parameter :: error_header = & '==>Error from coupler_types_mod (coupler_type_copy_3d_3d):' @@ -544,7 +553,7 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_3d_3d @@ -1174,8 +1183,10 @@ subroutine CT_copy_data_2d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: copy_bc @@ -1249,8 +1260,10 @@ subroutine CT_copy_data_3d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: copy_bc @@ -1329,8 +1342,10 @@ subroutine CT_copy_data_2d_3d(var_in, var, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this integer, optional, intent(in) :: ind3_start !< The starting value of the 3rd @@ -1563,8 +1578,10 @@ subroutine CT_rescale_data_2d(var, scale, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: do_bc @@ -1640,8 +1657,10 @@ subroutine CT_rescale_data_3d(var, scale, halo_size, bc_index, field_index, & !! that is being copied integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being copied - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this copy. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this copy. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this copy. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this copy. logical, optional, intent(in) :: pass_through_ice !< If true, only copy BCs whose !! value of pass_through ice matches this logical :: do_bc @@ -1718,8 +1737,10 @@ subroutine CT_increment_data_2d_2d(var_in, var, halo_size, bc_index, field_index !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1802,8 +1823,10 @@ subroutine CT_increment_data_3d_3d(var_in, var, halo_size, bc_index, field_index !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1893,8 +1916,10 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi !! boundary condition that is being copied real, optional, intent(in) :: scale_factor !< A scaling factor for the data that is being added real, optional, intent(in) :: scale_prev !< A scaling factor for the data that is already here - character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types of fluxes to exclude from this increment. - character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types of fluxes to include from this increment. + character(len=*), optional, intent(in) :: exclude_flux_type !< A string describing which types + !! of fluxes to exclude from this increment. + character(len=*), optional, intent(in) :: only_flux_type !< A string describing which types + !! of fluxes to include from this increment. logical, optional, intent(in) :: pass_through_ice !< If true, only increment BCs whose !! value of pass_through ice matches this @@ -1946,7 +1971,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi elseif ((1+var_in%ied-var_in%isd) == size(weights,1)) then iow = 1 + (var_in%isc - var_in%isd) - var%isc else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size of a computational or data domain.") + call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the i-size "//& + "of a computational or data domain.") endif if ((1+var%jec-var%jsc) == size(weights,2)) then jow = 1 - var%jsc @@ -1955,7 +1981,8 @@ subroutine CT_increment_data_2d_3d(var_in, weights, var, halo_size, bc_index, fi elseif ((1+var_in%jed-var_in%jsd) == size(weights,2)) then jow = 1 + (var_in%jsc - var_in%jsd) - var%jsc else - call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size of a computational or data domain.") + call mpp_error(FATAL, "CT_increment_data_2d_3d: weights array must be the j-size "//& + "of a computational or data domain.") endif io1 = var_in%isc - var%isc ; jo1 = var_in%jsc - var%jsc ; kow = 1 - var_in%ks @@ -2720,7 +2747,8 @@ end subroutine CT_set_data_3d !> This routine registers the diagnostics of a coupler_2d_bc_type. subroutine CT_set_diags_2d(var, diag_name, axes, time) type(coupler_2d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field @@ -2746,7 +2774,8 @@ end subroutine CT_set_diags_2d !> This routine registers the diagnostics of a coupler_3d_bc_type. subroutine CT_set_diags_3d(var, diag_name, axes, time) type(coupler_3d_bc_type), intent(inout) :: var !< BC_type structure for which to register diagnostics - character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, then don't register the fields + character(len=*), intent(in) :: diag_name !< name for diagnostic file--if blank, + !! then don't register the fields integer, dimension(:), intent(in) :: axes !< array of axes identifiers for diagnostic variable registration type(time_type), intent(in) :: time !< model time variable for registering diagnostic field diff --git a/config_src/solo_driver/user_surface_forcing.F90 b/config_src/solo_driver/user_surface_forcing.F90 index 61084cb3f6..6a70999d50 100644 --- a/config_src/solo_driver/user_surface_forcing.F90 +++ b/config_src/solo_driver/user_surface_forcing.F90 @@ -44,7 +44,7 @@ module user_surface_forcing !* * !********+*********+*********+*********+*********+*********+*********+** use MOM_diag_mediator, only : post_data, query_averaging_enabled -use MOM_diag_mediator, only : register_diag_field, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, safe_alloc_ptr use MOM_domains, only : pass_var, pass_vector, AGRID use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, param_file_type, log_version @@ -85,13 +85,17 @@ module user_surface_forcing contains +!> This subroutine sets the surface wind stresses, forces%taux and forces%tauy. +!! These are the stresses in the direction of the model grid (i.e. the same +!! direction as the u- and v- velocities.) They are both in Pa. subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(time_type), intent(in) :: day + type(time_type), intent(in) :: day !< The time of the fluxes type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine sets the surface wind stresses, forces%taux and forces%tauy. ! These are the stresses in the direction of the model grid (i.e. the same @@ -147,15 +151,19 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, CS) end subroutine USER_wind_forcing +!> This subroutine specifies the current surface fluxes of buoyancy or +!! temperature and fresh water. It may also be modified to add +!! surface fluxes of user provided tracers. subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes - type(time_type), intent(in) :: day + !! describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes real, intent(in) :: dt !< The amount of time over which !! the fluxes apply, in s type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(user_surface_forcing_CS), pointer :: CS + type(user_surface_forcing_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to user_surface_forcing_init ! This subroutine specifies the current surface fluxes of buoyancy or ! temperature and fresh water. It may also be modified to add @@ -204,19 +212,19 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) ! Allocate and zero out the forcing arrays, as necessary. This portion is ! usually not changed. if (CS%use_temperature) then - call alloc_if_needed(fluxes%evap, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%fprec, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lrunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%frunoff, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%vprec, isd, ied, jsd, jed) - - call alloc_if_needed(fluxes%sw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%lw, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%latent, isd, ied, jsd, jed) - call alloc_if_needed(fluxes%sens, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%evap, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%fprec, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lrunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%frunoff, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%vprec, isd, ied, jsd, jed) + + call safe_alloc_ptr(fluxes%sw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%lw, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%latent, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%sens, isd, ied, jsd, jed) else ! This is the buoyancy only mode. - call alloc_if_needed(fluxes%buoy, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%buoy, isd, ied, jsd, jed) endif @@ -250,7 +258,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) if (CS%restorebuoy) then if (CS%use_temperature) then - call alloc_if_needed(fluxes%heat_added, isd, ied, jsd, jed) + call safe_alloc_ptr(fluxes%heat_added, isd, ied, jsd, jed) ! When modifying the code, comment out this error message. It is here ! so that the original (unmodified) version is not accidentally used. call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & @@ -290,24 +298,15 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, CS) end subroutine USER_buoyancy_forcing -subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) - ! If ptr is not associated, this routine allocates it with the given size - ! and zeros out its contents. This is equivalent to safe_alloc_ptr in - ! MOM_diag_mediator, but is here so as to be completely transparent. - real, pointer :: ptr(:,:) - integer :: isd, ied, jsd, jed - if (.not.ASSOCIATED(ptr)) then - allocate(ptr(isd:ied,jsd:jed)) - ptr(:,:) = 0.0 - endif -end subroutine alloc_if_needed - +!> This subroutine initializes the USER_surface_forcing module subroutine USER_surface_forcing_init(Time, G, param_file, diag, CS) - type(time_type), intent(in) :: Time + type(time_type), intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(in) :: diag - type(user_surface_forcing_CS), pointer :: CS + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate diagnostic output. + type(user_surface_forcing_CS), pointer :: CS !< A pointer that is set to point to + !! the control structure for this module + ! Arguments: Time - The current model time. ! (in) G - The ocean's grid structure. ! (in) param_file - A structure indicating the open file to parse for diff --git a/pkg/MOM6_DA_hooks b/pkg/MOM6_DA_hooks new file mode 160000 index 0000000000..6d8834ca8c --- /dev/null +++ b/pkg/MOM6_DA_hooks @@ -0,0 +1 @@ +Subproject commit 6d8834ca8cf399f1a0d202239d72919907f6cd74 diff --git a/pkg/geoKdTree b/pkg/geoKdTree new file mode 160000 index 0000000000..a4670b9743 --- /dev/null +++ b/pkg/geoKdTree @@ -0,0 +1 @@ +Subproject commit a4670b9743c883d310d821eeac5b1f77f587b9d5 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index d068115753..c56d8a3fc3 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -45,7 +45,6 @@ module MOM_ALE use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_verticalGrid, only : get_thickness_units, verticalGrid_type -use regrid_defs, only : PRESSURE_RECONSTRUCTION_PLM !use regrid_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE use regrid_consts, only : coordinateUnits, coordinateMode, state_dependent use regrid_edge_values, only : edge_values_implicit_h4 @@ -60,22 +59,7 @@ module MOM_ALE !> ALE control structure -type, public :: ALE_CS - private - - logical :: boundary_extrapolation_for_pressure !< Indicate whether high-order boundary - !! extrapolation should be used within boundary cells - - logical :: reconstructForPressure = .false. !< Indicates whether integrals for FV - !! pressure gradient calculation will - !! use reconstruction of T/S. - !! By default, it is true if regridding - !! has been initialized, otherwise false. - - integer :: pressureReconstructionScheme !< Form of the reconstruction of T/S - !! for FV pressure gradient calculation. - !! By default, it is =1 (PLM) - +type, public :: ALE_CS ; private 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. @@ -87,8 +71,6 @@ module MOM_ALE type(remapping_CS) :: remapCS !< Remapping parameters and work arrays integer :: nk !< Used only for queries, not directly by this module - integer :: degree_linear=1 !< Degree of linear piecewise polynomial - integer :: degree_parab=2 !< Degree of parabolic piecewise polynomial logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. @@ -126,8 +108,6 @@ module MOM_ALE public ALE_remap_scalar public pressure_gradient_plm public pressure_gradient_ppm -public usePressureReconstruction -public pressureReconstructionScheme public adjustGridForIntegrity public ALE_initRegridding public ALE_getCoordinate @@ -172,33 +152,6 @@ subroutine ALE_init( param_file, GV, max_depth, CS) CS%show_call_tree = callTree_showQuery() if (CS%show_call_tree) call callTree_enter("ALE_init(), MOM_ALE.F90") - ! --- BOUNDARY EXTRAPOLATION -- - ! This sets whether high-order (rather than PCM) reconstruction schemes - ! should be used within boundary cells - call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", & - CS%boundary_extrapolation_for_pressure, & - "When defined, the reconstruction is extrapolated\n"//& - "within boundary cells rather than assume PCM for the.\n"//& - "calculation of pressure. e.g. if PPM is used, a\n"//& - "PPM reconstruction will also be used within\n"//& - "boundary cells.", default=.true.) - - ! --- PRESSURE GRADIENT CALCULATION --- - call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", & - CS%reconstructForPressure , & - "If True, use vertical reconstruction of T/S within\n"//& - "the integrals of teh FV pressure gradient calculation.\n"//& - "If False, use the constant-by-layer algorithm.\n"//& - "By default, this is True when using ALE and False otherwise.", & - default=.true. ) - - call get_param(param_file, mdl, "PRESSURE_RECONSTRUCTION_SCHEME", & - CS%pressureReconstructionScheme, & - "Type of vertical reconstruction of T/S to use in integrals\n"//& - "within the FV pressure gradient calculation."//& - " 1: PLM reconstruction.\n"//& - " 2: PPM reconstruction.", default=PRESSURE_RECONSTRUCTION_PLM) - call get_param(param_file, mdl, "REMAP_UV_USING_OLD_ALG", & CS%remap_uv_using_old_alg, & "If true, uses the old remapping-via-a-delta-z method for\n"//& @@ -342,7 +295,8 @@ end subroutine ALE_end subroutine ALE_main( G, GV, h, u, v, tv, Reg, CS, dt, frac_shelf_h) 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 obtained after last time step (m or Pa) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step (m or Pa) real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity field (m/s) real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity field (m/s) type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure @@ -407,12 +361,10 @@ subroutine ALE_main( G, GV, h, u, v, tv, Reg, CS, dt, frac_shelf_h) ! 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(isc,iec,jsc,jec,nk,h,h_new,CS) - 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 + !$OMP parallel do default(shared) + 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()") @@ -428,7 +380,8 @@ end subroutine ALE_main subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, dt) 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 obtained after last time step (m or Pa) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step (m or Pa) type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure type(ALE_CS), pointer :: CS !< Regridding parameters and options @@ -463,12 +416,10 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, dt) ! 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(isc,iec,jsc,jec,nk,h,h_new,CS) - 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 + !$OMP parallel do default(shared) + 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%id_dzRegrid>0 .and. present(dt)) call post_data(CS%id_dzRegrid, dzRegrid, CS%diag) @@ -539,7 +490,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug) endif call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), 0., Kd(i,j,:)) endif - enddo ; enddo; + enddo ; enddo call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T) call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S) @@ -561,7 +512,7 @@ end subroutine ALE_offline_inputs subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS) 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 obtained after + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the !! last time step (m or Pa) type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_target !< Current 3D grid obtained after @@ -603,9 +554,10 @@ end subroutine ALE_offline_tracer_final !> Check grid for negative thicknesses subroutine check_grid( G, GV, h, threshold ) - 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 !< Current 3D grid obtained after the last time step (H units) + 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 !< Current 3D grid obtained after the + !! last time step (H units) real, intent(in) :: threshold !< Value below which to flag issues (H units) ! Local variables integer :: i, j @@ -633,7 +585,8 @@ subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h 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 (m or Pa) + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the + !! last time step (m or Pa) logical, optional, intent(in) :: debug !< If true, show the call tree real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage ! Local variables @@ -670,34 +623,35 @@ 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_orig, tv, n, h_new, u, v) - type(ALE_CS), intent(in) :: 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(in) :: h_orig !< Original thicknesses - type(thermo_var_ptrs), intent(inout) :: tv !< Thermo vars (T/S/EOS) - integer, intent(in) :: n !< Number of times to regrid - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h_new !< Thicknesses after regridding - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity +subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, 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 + type(thermo_var_ptrs), intent(inout) :: tv !< Thermo vars (T/S/EOS) + integer, intent(in) :: n !< Number of times to regrid + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity + type(tracer_registry_type), & + optional, pointer :: Reg !< Tracer registry to remap onto new grid + real, optional, intent(in) :: dt !< Model timestep to provide a timescale for regridding + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(inout) :: dzRegrid !< Final change in interface positions + logical, optional, intent(in) :: initial !< Whether we're being called from an initialization + !! routine (and expect diagnostics to work) ! Local variables integer :: i, j, k, 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 ! A working copy of layer thickesses - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T, S ! temporary state + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thicknesses + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T, S ! local temporary state ! 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 - - !### Try replacing both of these with GV%H_subroundoff - if (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 nz = GV%ke @@ -706,7 +660,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h_orig, tv, n, h_new, u, v) call create_group_pass(pass_T_S_h, T, G%domain) call create_group_pass(pass_T_S_h, S, G%domain) - call create_group_pass(pass_T_S_h, h, G%domain) + call create_group_pass(pass_T_S_h, h_loc, G%domain) ! copy original temp/salt and set our local tv_pointers to them tv_local = tv @@ -715,36 +669,36 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h_orig, tv, n, h_new, u, v) tv_local%T => T tv_local%S => S - ! get local copy of thickness - h(:,:,:) = h_orig(:,:,:) + ! get local copy of thickness and save original state for remapping + h_loc(:,:,:) = h(:,:,:) + h_orig(:,:,:) = h(:,:,:) + + ! Apply timescale to regridding (for e.g. filtered_grid_motion) + if (present(dt)) & + call ALE_update_regrid_weights(dt, CS) do k = 1, n call do_group_pass(pass_T_S_h, G%domain) ! generate new grid - call regridding_main(CS%remapCS, CS%regridCS, G, GV, h, tv_local, h_new, dzInterface) + call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface) dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! remap from original grid onto new grid - ! we need to use remapping_core because there isn't a tracer registry set up in - ! the state initialization routine - do j = G%jsc,G%jec ; do i = G%isc,G%iec - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h_new(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_new(i,j,:), & - tv_local%T(i,j,:), h_neglect, h_neglect_edge) + 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,:)) enddo ; enddo - - h(:,:,:) = h_new(:,:,:) + ! starting grid for next iteration + h_loc(:,:,:) = h(:,:,:) enddo - ! save the final temp/salt - tv%S(:,:,:) = S(:,:,:) - tv%T(:,:,:) = T(:,:,:) + ! 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, dzIntTotal, u, v, dt=dt) - ! remap velocities - call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h_new, null(), dzIntTotal, u, v) + ! save total dzregrid for diags if needed? + if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) end subroutine ALE_regrid_accelerated !> This routine takes care of remapping all variable between the old and the @@ -754,18 +708,21 @@ end subroutine ALE_regrid_accelerated !! remap initiali 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, dxInterface, u, v, debug, dt) - type(remapping_CS), intent(in) :: CS_remapping !< Remapping control structure - type(ALE_CS), intent(in) :: CS_ALE !< 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 (m or Pa) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid (m or Pa) - type(tracer_registry_type), pointer :: Reg !< Tracer registry structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1),optional, intent(in) :: dxInterface !< Change in interface position (Hm or Pa) - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: u !< Zonal velocity component (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), optional, intent(inout) :: v !< Meridional velocity component (m/s) - logical, optional, intent(in) :: debug !< If true, show the call tree - real, optional, intent(in) :: dt !< time step for diagnostics + type(remapping_CS), intent(in) :: CS_remapping !< Remapping control structure + type(ALE_CS), intent(in) :: CS_ALE !< 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 (m or Pa) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid (m or Pa) + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(in) :: dxInterface !< Change in interface position (Hm or Pa) + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: u !< Zonal velocity component (m/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(inout) :: v !< Meridional velocity component (m/s) + logical, optional, intent(in) :: debug !< If true, show the call tree + real, optional, intent(in) :: dt !< time step for diagnostics ! Local variables integer :: i, j, k, m integer :: nz, ntr @@ -787,8 +744,8 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! If remap_uv_using_old_alg is .true. and u or v is requested, then we must have dxInterface. Otherwise, ! u and v can be remapped without dxInterface if ( .not. present(dxInterface) .and. (CS_ALE%remap_uv_using_old_alg .and. (present(u) .or. present(v))) ) then - call MOM_error(FATAL, "remap_all_state_vars: dxInterface must be present if using old algorithm and u/v are to"// & - "be remapped") + call MOM_error(FATAL, "remap_all_state_vars: dxInterface must be present if using old algorithm "// & + "and u/v are to be remapped") endif !### Try replacing both of these with GV%H_subroundoff @@ -817,33 +774,29 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, !$OMP parallel do default(shared) private(h1,h2,u_column,Tr) 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) - - ! 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 - 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 - enddo - endif - endif - ! update tracer concentration - Tr%t(i,j,:) = u_column(:) + 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) + + ! 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 + enddo endif - enddo ! i - enddo ! j + 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 + enddo + endif + endif + ! update tracer concentration + Tr%t(i,j,:) = u_column(:) + endif ; enddo ; enddo ! tendency diagnostics. if (Tr%id_remap_conc > 0) then @@ -853,14 +806,12 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) endif if (Tr%id_remap_cont_2d > 0) then - do j = G%jsc,G%jec - do i = G%isc,G%iec - work_2d(i,j) = 0.0 - do k = 1,GV%ke - work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) - enddo + do j = G%jsc,G%jec ; do i = G%isc,G%iec + work_2d(i,j) = 0.0 + do k = 1,GV%ke + work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) enddo - enddo + enddo ; enddo call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) endif @@ -873,25 +824,21 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap u velocity component if ( present(u) ) then !$OMP parallel do default(shared) private(h1,h2,dx,u_column) - 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 - dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i+1,j,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) - enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) - 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(:) - endif - enddo - enddo + 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 + dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i+1,j,:) ) + do k = 1, nz + h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) + enddo + else + h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) + 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(:) + endif ; enddo ; enddo endif if (show_call_tree) call callTree_waypoint("u remapped (remap_all_state_vars)") @@ -899,25 +846,21 @@ 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,dx,u_column) - 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 - dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i,j+1,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) - enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) - 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(:) - endif - enddo - enddo + 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 + dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i,j+1,:) ) + do k = 1, nz + h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) + enddo + else + h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) + 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(:) + 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) @@ -1000,72 +943,71 @@ end subroutine ALE_remap_scalar !! routine determines the edge values for the salinity and temperature !! within each layer. These edge values are returned and are used to compute !! the pressure gradient (by computing the densities). -subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(ALE_CS), intent(inout) :: CS !< module control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S_t !< Salinity at the top edge of each layer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S_b !< Salinity at the bottom edge of each layer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T_t !< Temperature at the top edge of each layer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T_b !< Temperature at the bottom edge of each layer - type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness +subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ALE_CS), intent(inout) :: CS !< module control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_t !< Salinity at the top edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_b !< Salinity at the bottom edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_t !< Temperature at the top edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_b !< Temperature at the bottom edge of each layer + type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thickness in H + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells ! Local variables integer :: i, j, k real :: hTmp(GV%ke) real :: tmp(GV%ke) - real, dimension(CS%nk,2) :: ppoly_linear_E !Edge value of polynomial - real, dimension(CS%nk,CS%degree_linear+1) :: ppoly_linear_coefs !Coefficients of polynomial + real, dimension(CS%nk,2) :: ppol_E !Edge value of polynomial + real, dimension(CS%nk,2) :: ppol_coefs !Coefficients of polynomial real :: h_neglect !### Replace this with GV%H_subroundoff - !### Omit the rescaling by H_to_m here. It should not be needed. if (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 * GV%H_to_m + h_neglect = GV%m_to_H*1.0e-30 else - h_neglect = GV%kg_m2_to_H*1.0e-30 * GV%H_to_m + h_neglect = GV%kg_m2_to_H*1.0e-30 endif - ! NOTE: the variables 'CS%grid_generic' and 'CS%ppoly_linear' are declared at - ! the module level. - ! Determine reconstruction within each column -!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b,h_neglect) & -!$OMP private(hTmp,ppoly_linear_E,ppoly_linear_coefs,tmp) - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - ! Build current grid - !### Omit the rescaling by H_to_m here. It should not be needed. - hTmp(:) = h(i,j,:)*GV%H_to_m - tmp(:) = tv%S(i,j,:) - ! Reconstruct salinity profile - ppoly_linear_E(:,:) = 0.0 - ppoly_linear_coefs(:,:) = 0.0 - call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) - if (CS%boundary_extrapolation_for_pressure) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppoly_linear_E(k,1) - S_b(i,j,k) = ppoly_linear_E(k,2) - end do - - ! Reconstruct temperature profile - ppoly_linear_E(:,:) = 0.0 - ppoly_linear_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - call PLM_reconstruction( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) - if (CS%boundary_extrapolation_for_pressure) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_linear_E, ppoly_linear_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppoly_linear_E(k,1) - T_b(i,j,k) = ppoly_linear_E(k,2) - end do - - end do - end do + !$OMP parallel do default(shared) private(hTmp,ppol_E,ppol_coefs,tmp) + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + ! Build current grid + hTmp(:) = h(i,j,:) + tmp(:) = tv%S(i,j,:) + ! Reconstruct salinity profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + S_t(i,j,k) = ppol_E(k,1) + S_b(i,j,k) = ppol_E(k,2) + enddo + + ! Reconstruct temperature profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + tmp(:) = tv%T(i,j,:) + call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + T_t(i,j,k) = ppol_E(k,1) + T_b(i,j,k) = ppol_E(k,2) + enddo + + enddo ; enddo end subroutine pressure_gradient_plm @@ -1075,110 +1017,82 @@ end subroutine pressure_gradient_plm !> routine determines the edge values for the salinity and temperature !> within each layer. These edge values are returned and are used to compute !> the pressure gradient (by computing the densities). -subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h ) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(ALE_CS), intent(inout) :: CS !< module control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S_t !< Salinity at top edge of each layer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: S_b !< Salinity at bottom edge of each layer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T_t !< Temperature at the top edge of each layer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: T_b !< Temperature at the bottom edge of each layer - type(thermo_var_ptrs), intent(in) :: tv !< ocean thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness +subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_extrap ) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(ALE_CS), intent(inout) :: CS !< module control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_t !< Salinity at the top edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: S_b !< Salinity at the bottom edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_t !< Temperature at the top edge of each layer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: T_b !< Temperature at the bottom edge of each layer + type(thermo_var_ptrs), intent(in) :: tv !< thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< layer thicknesses in H + logical, intent(in) :: bdry_extrap !< If true, use high-order boundary + !! extrapolation within boundary cells ! Local variables integer :: i, j, k real :: hTmp(GV%ke) real :: tmp(GV%ke) real, dimension(CS%nk,2) :: & - ppoly_parab_E !Edge value of polynomial - real, dimension(CS%nk,CS%degree_parab+1) :: & - ppoly_parab_coefs !Coefficients of polynomial - real :: h_neglect + ppol_E !Edge value of polynomial + real, dimension(CS%nk,3) :: & + ppol_coefs !Coefficients of polynomial + real :: h_neglect, h_neglect_edge - !### Replace this with GV%H_subroundoff - !### Omit the rescaling by H_to_m here. It should not be needed. + !### Try replacing both of these with GV%H_subroundoff if (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 * GV%H_to_m + 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 * GV%H_to_m + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 endif - ! NOTE: the variables 'CS%grid_generic' and 'CS%ppoly_parab' are declared at - ! the module level. - ! Determine reconstruction within each column -!$OMP parallel do default(none) shared(G,GV,h,tv,CS,S_t,S_b,T_t,T_b,h_neglect) & -!$OMP private(hTmp,tmp,ppoly_parab_E,ppoly_parab_coefs) - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - - ! Build current grid - !### Omit the rescaling by H_to_m here. It should not be needed. - hTmp(:) = h(i,j,:) * GV%H_to_m - tmp(:) = tv%S(i,j,:) - - ! Reconstruct salinity profile - ppoly_parab_E(:,:) = 0.0 - ppoly_parab_coefs(:,:) = 0.0 - !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E, h_neglect=1.0e-10) !###*GV%m_to_H ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefs, h_neglect ) - if (CS%boundary_extrapolation_for_pressure) call & - PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, & - ppoly_parab_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppoly_parab_E(k,1) - S_b(i,j,k) = ppoly_parab_E(k,2) - end do - - ! Reconstruct temperature profile - ppoly_parab_E(:,:) = 0.0 - ppoly_parab_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppoly_parab_E, h_neglect=1.0e-10) !###*GV%m_to_H ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppoly_parab_E, ppoly_parab_coefs, h_neglect ) - if (CS%boundary_extrapolation_for_pressure) call & - PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppoly_parab_E, & - ppoly_parab_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppoly_parab_E(k,1) - T_b(i,j,k) = ppoly_parab_E(k,2) - end do - - end do - end do - -end subroutine pressure_gradient_ppm - - -!> pressure reconstruction logical -logical function usePressureReconstruction(CS) - type(ALE_CS), pointer :: CS !< control structure - - if (associated(CS)) then - usePressureReconstruction=CS%reconstructForPressure - else - usePressureReconstruction=.false. - endif - -end function usePressureReconstruction + !$OMP parallel do default(shared) private(hTmp,tmp,ppol_E,ppol_coefs) + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + + ! Build current grid + hTmp(:) = h(i,j,:) + tmp(:) = tv%S(i,j,:) + + ! Reconstruct salinity profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + S_t(i,j,k) = ppol_E(k,1) + S_b(i,j,k) = ppol_E(k,2) + enddo + ! Reconstruct temperature profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + tmp(:) = tv%T(i,j,:) + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + T_t(i,j,k) = ppol_E(k,1) + T_b(i,j,k) = ppol_E(k,2) + enddo -!> pressure reconstruction integer -integer function pressureReconstructionScheme(CS) - type(ALE_CS), pointer :: CS !< control structure + enddo ; enddo - if (associated(CS)) then - pressureReconstructionScheme=CS%pressureReconstructionScheme - else - pressureReconstructionScheme=-1 - endif +end subroutine pressure_gradient_ppm -end function pressureReconstructionScheme !> Initializes regridding for the main ALE algorithm subroutine ALE_initRegridding(GV, max_depth, param_file, mdl, regridCS) @@ -1311,7 +1225,7 @@ subroutine ALE_initThicknessToCoord( CS, G, GV, h ) do j = G%jsd,G%jed ; do i = G%isd,G%ied h(i,j,:) = GV%m_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j) ) - enddo; enddo + enddo ; enddo end subroutine ALE_initThicknessToCoord diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index e9f755746e..ebe8b93bf6 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -6,8 +6,7 @@ module MOM_regridding use MOM_error_handler, only : MOM_error, FATAL, WARNING 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, write_field, close_file, slasher +use MOM_io, only : slasher use MOM_variables, only : ocean_grid_type, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type, calculate_density @@ -42,7 +41,7 @@ module MOM_regridding !> This array is set by function setCoordinateResolution() !! It contains the "resolution" or delta coordinate of the target - !! coorindate. It has the units of the target coordiante, e.g. + !! coorindate. It has the units of the target coordinate, e.g. !! meters for z*, non-dimensional for sigma, etc. real, dimension(:), allocatable :: coordinateResolution @@ -62,7 +61,7 @@ module MOM_regridding !! It specifies the maximum depth that every interface is allowed to take, in H. real, dimension(:), allocatable :: max_layer_thickness - integer :: nk !< Number of layers/levels + integer :: nk !< Number of layers/levels in generated grid !> Indicates which grid to use in the vertical (z*, sigma, target interface !! densities) @@ -117,7 +116,6 @@ module MOM_regridding ! The following routines are visible to the outside world public initialize_regridding, end_regridding, regridding_main public inflate_vanished_layers_old, check_remapping_grid, check_grid_column -public adjust_interface_motion public set_regrid_params, get_regrid_size public uniformResolution, setCoordinateResolution public build_rho_column @@ -532,7 +530,7 @@ subroutine initialize_regridding(CS, GV, max_depth, param_file, mod, coord_mode, if (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then call get_param(param_file, mod, "ADAPT_TIME_RATIO", adaptTimeRatio, & - "Ratio of ALE timestep to grid timescale.", units="s", default=1e-1) + "Ratio of ALE timestep to grid timescale.", units="s", default=1e-1) !### Should the units be "nondim"? call get_param(param_file, mod, "ADAPT_ZOOM_DEPTH", adaptZoom, & "Depth of near-surface zooming region.", units="m", default=200.0) call get_param(param_file, mod, "ADAPT_ZOOM_COEFF", adaptZoomCoeff, & @@ -696,7 +694,7 @@ subroutine check_grid_def(filename, varname, expected_units, msg, ierr) integer :: i ierr = .false. - status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid); + status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then ierr = .true. msg = 'File not found: '//trim(filename) @@ -758,8 +756,7 @@ subroutine end_regridding(CS) end subroutine end_regridding !------------------------------------------------------------------------------ -! Dispatching regridding routine: regridding & remapping -!------------------------------------------------------------------------------ +!> Dispatching regridding routine for orchestrating regridding & remapping subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_shelf_h, conv_adjust) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between @@ -783,12 +780,13 @@ 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 the last time step + real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: 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), SZK_(GV)), intent(inout) :: h_new !< New 3D grid consistent with target coordinate - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in position of each interface - real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage - logical, optional, intent(in ) :: conv_adjust ! If true, do convective adjustment + 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 + real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage + logical, optional, intent(in ) :: conv_adjust !< If true, do convective adjustment ! Local variables real :: trickGnuCompiler logical :: use_ice_shelf @@ -810,36 +808,35 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ else call build_zstar_grid( CS, G, GV, h, dzInterface ) endif - call calc_h_new_by_dz(G, GV, h, dzInterface, h_new) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SIGMA_SHELF_ZSTAR) call build_zstar_grid( CS, G, GV, h, dzInterface ) - call calc_h_new_by_dz(G, GV, h, dzInterface, h_new) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SIGMA ) call build_sigma_grid( CS, G, GV, h, dzInterface ) - call calc_h_new_by_dz(G, GV, h, dzInterface, h_new) + 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, h, tv, dzInterface, remapCS, CS ) - call calc_h_new_by_dz(G, GV, h, dzInterface, h_new) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ARBITRARY ) call build_grid_arbitrary( G, GV, h, dzInterface, trickGnuCompiler, CS ) - call calc_h_new_by_dz(G, GV, h, dzInterface, h_new) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) - call build_grid_HyCOM1( G, GV, h, tv, dzInterface, CS ) - call calc_h_new_by_dz(G, GV, h, dzInterface, h_new) + call build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) case ( REGRIDDING_SLIGHT ) call build_grid_SLight( G, GV, h, tv, dzInterface, CS ) - call calc_h_new_by_dz(G, GV, h, dzInterface, h_new) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) call build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) - call calc_h_new_by_dz(G, GV, h, dzInterface, h_new) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case default call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& @@ -854,24 +851,34 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ end subroutine regridding_main !> Calculates h_new from h + delta_k dzInterface -subroutine calc_h_new_by_dz(G, GV, h, dzInterface, h_new) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses (m) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: dzInterface !< Change in interface positions (m) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_new !< New layer thicknesses (m) +subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses (m) + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions (m) + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses (m) ! Local variables - integer :: i, j, k + integer :: i, j, k, nki + + nki = min(CS%nk, GV%ke) -!$OMP parallel do default(none) shared(G,GV,h,dzInterface,h_new) + !$OMP parallel do default(shared) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then - do k=1,GV%ke + do k=1,nki h_new(i,j,k) = max( 0., h(i,j,k) + ( dzInterface(i,j,k) - dzInterface(i,j,k+1) ) ) enddo + if (CS%nk > GV%ke) then + do k=nki+1, CS%nk + h_new(i,j,k) = max( 0., dzInterface(i,j,k) - dzInterface(i,j,k+1) ) + enddo + endif else - h_new(i,j,:) = h(i,j,:) + h_new(i,j,1:nki) = h(i,j,1:nki) + if (CS%nk > GV%ke) h_new(i,j,nki+1:CS%nk) = 0. + ! On land points, why are we keeping the original h rather than setting to zero? -AJA endif enddo enddo @@ -888,7 +895,7 @@ subroutine check_remapping_grid( G, GV, h, dzInterface, msg ) ! Local variables integer :: i, j -!$OMP parallel do default(none) shared(G,GV,h,dzInterface,msg) + !$OMP parallel do default(shared) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) call check_grid_column( GV%ke, G%bathyT(i,j), h(i,j,:), dzInterface(i,j,:), msg ) @@ -960,14 +967,14 @@ end subroutine check_grid_column !! over the trajectory of the interface. By design, this code can not give !! tangled interfaces provided that z_old and z_new are not already tangled. subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) - type(regridding_CS), intent(in) :: CS !< Regridding control structure - integer, intent(in) :: nk !< Number of cells - real, dimension(nk+1), intent(in) :: z_old !< Old grid position (m) - real, dimension(nk+1), intent(in) :: z_new !< New grid position (m) - real, dimension(nk+1), intent(inout) :: dz_g !< Change in interface positions (m) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + integer, intent(in) :: nk !< Number of cells in source grid + real, dimension(nk+1), intent(in) :: z_old !< Old grid position (m) + real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position (m) + real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions (m) ! Local variables real :: sgn ! The sign convention for downward. - real :: dz_tgt, zr1 + real :: dz_tgt, zr1, z_old_k real :: Aq, Bq, dz0, z0, F0 real :: zs, zd, dzwt, Idzwt real :: wtd, Iwtd @@ -978,21 +985,23 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) logical :: debug = .false. integer :: k - if ((z_old(nk+1) - z_old(1)) * (z_new(nk+1) - z_new(1)) < 0.0) then + if ((z_old(nk+1) - z_old(1)) * (z_new(CS%nk+1) - z_new(1)) < 0.0) then call MOM_error(FATAL, "filtered_grid_motion: z_old and z_new use different sign conventions.") - elseif ((z_old(nk+1) - z_old(1)) * (z_new(nk+1) - z_new(1)) == 0.0) then + elseif ((z_old(nk+1) - z_old(1)) * (z_new(CS%nk+1) - z_new(1)) == 0.0) then ! This is a massless column, so do nothing and return. - do k=1,nk+1 ; dz_g(k) = 0.0 ; enddo ; return - elseif ((z_old(nk+1) - z_old(1)) + (z_new(nk+1) - z_new(1)) > 0.0) then + do k=1,CS%nk+1 ; dz_g(k) = 0.0 ; enddo ; return + elseif ((z_old(nk+1) - z_old(1)) + (z_new(CS%nk+1) - z_new(1)) > 0.0) then sgn = 1.0 else sgn = -1.0 endif if (debug) then - do k=2,nk+1 + do k=2,CS%nk+1 if (sgn*(z_new(k)-z_new(k-1)) < -5e-16*(abs(z_new(k))+abs(z_new(k-1))) ) & call MOM_error(FATAL, "filtered_grid_motion: z_new is tangled.") + enddo + do k=2,nk+1 if (sgn*(z_old(k)-z_old(k-1)) < -5e-16*(abs(z_old(k))+abs(z_old(k-1))) ) & call MOM_error(FATAL, "filtered_grid_motion: z_old is tangled.") enddo @@ -1010,10 +1019,12 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) Aq = 0.5*(Iwtd - 1.0) dz_g(1) = 0.0 - do k = 2,nk + z_old_k = z_old(1) + do k = 2,CS%nk+1 + if (k<=nk+1) z_old_k = z_old(k) ! This allows for virtual z_old interface at bottom of the model ! zr1 is positive and increases with depth, and dz_tgt is positive downward. - dz_tgt = sgn*(z_new(k) - z_old(k)) - zr1 = sgn*(z_old(k) - z_old(1)) + dz_tgt = sgn*(z_new(k) - z_old_k) + zr1 = sgn*(z_old_k - z_old(1)) ! First, handle the two simple and common cases that do not pass through ! the adjustment rate transition zone. @@ -1074,11 +1085,15 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) endif enddo - dz_g(nk+1) = 0.0 + !dz_g(CS%nk+1) = 0.0 if (debug) then - do k=1,nk+1 ; z_act(k) = z_old(k) + dz_g(k) ; enddo - do k=2,nk+1 + z_old_k = z_old(1) + do k=1,CS%nk+1 + if (k<=nk+1) z_old_k = z_old(k) ! This allows for virtual z_old interface at bottom of the model + z_act(k) = z_old_k + dz_g(k) + enddo + do k=2,CS%nk+1 if (sgn*((z_act(k))-z_act(k-1)) < -1e-15*(abs(z_act(k))+abs(z_act(k-1))) ) & call MOM_error(FATAL, "filtered_grid_motion: z_output is tangled.") enddo @@ -1092,12 +1107,12 @@ end subroutine filtered_grid_motion subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) ! 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth in H. - real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage. + 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 !< Layer thicknesses, in H + real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth in H. + real, dimension(:,:), optional, pointer :: frac_shelf_h !< Fractional ice shelf coverage. ! Local variables integer :: i, j, k integer :: nz @@ -1132,7 +1147,7 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) - end do + enddo zOld(nz+1) = - nominalDepth do k = nz,1,-1 @@ -1141,15 +1156,15 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) if (ice_shelf) then if (frac_shelf_h(i,j) > 0.) then ! under ice shelf - call build_zstar_column(CS%zlike_CS, nz, nominalDepth, totalThickness, zNew, & + call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, zNew, & z_rigid_top = totalThickness-nominalDepth, & eta_orig=zOld(1), zScale=GV%m_to_H) else - call build_zstar_column(CS%zlike_CS, nz, nominalDepth, totalThickness, & + call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & zNew, zScale=GV%m_to_H) endif else - call build_zstar_column(CS%zlike_CS, nz, nominalDepth, totalThickness, & + call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & zNew, zScale=GV%m_to_H) endif @@ -1173,16 +1188,16 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) endif #endif - call adjust_interface_motion( nz, CS%min_thickness, h(i,j,:), dzInterface(i,j,:) ) + call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) - end do - end do + enddo + enddo end subroutine build_zstar_grid !------------------------------------------------------------------------------ ! Build sigma grid -!------------------------------------------------------------------------------ +!> This routine builds a grid based on terrain-following coordinates. subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) !------------------------------------------------------------------------------ ! This routine builds a grid based on terrain-following coordinates. @@ -1192,11 +1207,11 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) !------------------------------------------------------------------------------ ! 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth in H. + 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 !< Layer thicknesses, in H + real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth in H. ! Local variables integer :: i, j, k @@ -1221,45 +1236,46 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) - end do + enddo - call build_sigma_column(CS%sigma_CS, nz, nominalDepth, totalThickness, zNew) + call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) ! Calculate the final change in grid position after blending new and old grids zOld(nz+1) = -nominalDepth do k = nz,1,-1 zOld(k) = zOld(k+1) + h(i, j, k) - end do + enddo 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 + if (abs(zNew(1)-zOld(1))>(CS%nk-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 + write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz,CS%nk do k=1,nz+1 write(0,*) k,zOld(k),zNew(k) enddo - do k=1,nz + do k=1,CS%nk write(0,*) k,h(i,j,k),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 dzInterface(i,j,1) = 0. - dzInterface(i,j,nz+1) = 0. + dzInterface(i,j,CS%nk+1) = 0. #endif - end do - end do + enddo + enddo end subroutine build_sigma_grid !------------------------------------------------------------------------------ ! Build grid based on target interface densities !------------------------------------------------------------------------------ +!> This routine builds a new grid based on a given set of target interface densities. subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) !------------------------------------------------------------------------------ ! This routine builds a new grid based on a given set of target interface @@ -1377,14 +1393,11 @@ subroutine build_rho_grid( G, GV, h, tv, dzInterface, remapCS, CS ) endif #endif - end do ! end loop on i - end do ! end loop on j + enddo ! end loop on i + enddo ! end loop on j end subroutine build_rho_grid - - - !> Builds a simple HyCOM-like grid with the deepest location of potential !! density interpolated from the column profile and a clipping of depth for !! each interface to a fixed z* or p* grid. This should probably be (optionally?) @@ -1392,19 +1405,21 @@ end subroutine build_rho_grid !! \remark { Based on Bleck, 2002: An oceanice general circulation model framed in !! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. !! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } -subroutine build_grid_HyCOM1( G, GV, h, tv, dzInterface, CS ) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness, in H units - 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 +subroutine build_grid_HyCOM1( G, GV, h, tv, h_new, dzInterface, CS ) + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness, in H units + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses (H units) + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position ! Local variables - real, dimension(SZK_(GV)+1) :: z_col, z_col_new ! Interface positions relative to the surface in H units (m or kg m-2) + real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface in H units (m or kg m-2) + real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface in H units (m or kg m-2) real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col in H units (m or kg m-2) real, dimension(SZK_(GV)) :: p_col ! Layer pressure in Pa - integer :: i, j, k, nz + integer :: i, j, k, nki real :: depth real :: h_neglect, h_neglect_edge @@ -1415,11 +1430,11 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, dzInterface, CS ) 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 (.not.CS%target_density_set) call MOM_error(FATAL, "build_grid_HyCOM1 : "//& "Target densities must be set before build_grid_HyCOM1 is called.") + nki = min(GV%ke, CS%nk) + ! Build grid based on target interface densities do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then @@ -1427,39 +1442,47 @@ subroutine build_grid_HyCOM1( G, GV, h, tv, dzInterface, CS ) depth = G%bathyT(i,j) * GV%m_to_H z_col(1) = 0. ! Work downward rather than bottom up - do K = 1, nz + do K = 1, GV%ke z_col(K+1) = z_col(K) + h(i,j,k) ! Work in units of h (m or Pa) p_col(k) = CS%ref_pressure + CS%compressibility_fraction * & ( 0.5 * ( z_col(K) + z_col(K+1) ) * GV%H_to_Pa - CS%ref_pressure ) enddo - call build_hycom1_column(CS%hycom_CS, tv%eqn_of_state, nz, depth, & + call build_hycom1_column(CS%hycom_CS, tv%eqn_of_state, GV%ke, depth, & h(i, j, :), tv%T(i, j, :), tv%S(i, j, :), p_col, & z_col, z_col_new, zScale=GV%m_to_H, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids - call filtered_grid_motion( CS, nz, z_col, z_col_new, dz_col ) - do K=1,nz+1 ; dzInterface(i,j,K) = -dz_col(K) ; enddo + call filtered_grid_motion( CS, GV%ke, z_col, z_col_new, dz_col ) ! This adjusts things robust to round-off errors - call adjust_interface_motion( nz, CS%min_thickness, h(i,j,:), dzInterface(i,j,:) ) + dz_col(:) = -dz_col(:) + call adjust_interface_motion( CS, GV%ke, h(i,j,:), dz_col(:) ) + + dzInterface(i,j,1:nki+1) = dz_col(1:nki+1) + if (nki This subroutine builds an adaptive grid that follows density surfaces where +!! possible, subject to constraints on the smoothness of interface heights. subroutine build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H (usually 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 - type(remapping_CS), intent(in) :: remapCS - type(regridding_CS), intent(in) :: CS + 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 in H + 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 @@ -1503,7 +1526,7 @@ subroutine build_grid_adaptive(G, GV, h, tv, dzInterface, remapCS, CS) call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) ! convert from depth to z do K = 1, nz+1 ; dzInterface(i,j,K) = -dzInterface(i,j,K) ; enddo - call adjust_interface_motion(nz, CS%min_thickness, h(i,j,:), dzInterface(i,j,:)) + call adjust_interface_motion(CS, nz, h(i,j,:), dzInterface(i,j,:)) enddo ; enddo end subroutine build_grid_adaptive @@ -1516,7 +1539,7 @@ end subroutine build_grid_adaptive !! shallow topography, this will tend to give a uniform sigma-like coordinate. !! For sufficiently shallow water, a minimum grid spacing is used to avoid !! certain instabilities. -subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) +subroutine build_grid_SLight(G, GV, h, tv, dzInterface, CS) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness, in H units @@ -1569,21 +1592,21 @@ subroutine build_grid_SLight( G, GV, h, tv, dzInterface, CS ) #endif ! This adjusts things robust to round-off errors - call adjust_interface_motion( nz, CS%min_thickness, h(i,j,:), dzInterface(i,j,:) ) + call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) else ! on land dzInterface(i,j,:) = 0. endif ! mask2dT - enddo; enddo ! i,j + enddo ; enddo ! i,j end subroutine build_grid_SLight !> Adjust dz_Interface to ensure non-negative future thicknesses -subroutine adjust_interface_motion( nk, min_thickness, h_old, dz_int ) - integer, intent(in) :: nk !< Number of layers - real, intent(in) :: min_thickness !< Minium allowed thickness of h (H units) - real, dimension(nk), intent(in) :: h_old !< Minium allowed thickness of h (H units) - real, dimension(nk+1), intent(inout) :: dz_int !< Minium allowed thickness of h (H units) +subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + integer, intent(in) :: nk !< Number of layers in h_old + real, dimension(nk), intent(in) :: h_old !< Minium allowed thickness of h (H units) + real, dimension(CS%nk+1), intent(inout) :: dz_int !< Minium allowed thickness of h (H units) ! Local variables integer :: k real :: h_new, eps, h_total, h_err @@ -1591,7 +1614,7 @@ subroutine adjust_interface_motion( nk, min_thickness, h_old, dz_int ) eps = 1. ; eps = epsilon(eps) h_total = 0. ; h_err = 0. - do k = 1, nk + do k = 1, min(CS%nk,nk) h_total = h_total + h_old(k) h_err = h_err + max( h_old(k), abs(dz_int(k)), abs(dz_int(k+1)) )*eps h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) @@ -1603,11 +1626,26 @@ subroutine adjust_interface_motion( nk, min_thickness, h_old, dz_int ) 'implied h<0 is larger than roundoff!') endif enddo - do k = nk,2,-1 + if (CS%nk>nk) then + do k = nk+1, CS%nk + h_err = h_err + max( abs(dz_int(k)), abs(dz_int(k+1)) )*eps + h_new = ( dz_int(k) - dz_int(k+1) ) + if (h_new < -3.0*h_err) then + write(0,*) 'h<0 at k=',k,'h_old was empty',& + 'wup=',dz_int(k),'wdn=',dz_int(k+1),'dw_dz=',dz_int(k) - dz_int(k+1), & + 'h_new=',h_new,'h_err=',h_err + call MOM_error( FATAL, 'MOM_regridding: adjust_interface_motion() - '//& + 'implied h<0 is larger than roundoff!') + endif + enddo + endif + do k = min(CS%nk,nk),2,-1 h_new = h_old(k) + ( dz_int(k) - dz_int(k+1) ) - if (h_new Achieve convective adjustment by swapping layers subroutine convective_adjustment(G, GV, h, tv) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables !------------------------------------------------------------------------------ ! Check each water column to see whether it is stratified. If not, sort the ! layers by successive swappings of water masses (bubble sort algorithm) !------------------------------------------------------------------------------ - ! Arguments - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables - ! Local variables integer :: i, j, k real :: T0, T1 ! temperatures @@ -1823,7 +1859,7 @@ subroutine convective_adjustment(G, GV, h, tv) 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 ) stratified = .false. - end if + endif enddo ! k if ( stratified ) exit @@ -1835,17 +1871,21 @@ end subroutine convective_adjustment !------------------------------------------------------------------------------ -! Return uniform resolution vector based on coordiante mode -!------------------------------------------------------------------------------ +!> Return a uniform resolution vector in the units of the coordinata function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) !------------------------------------------------------------------------------ ! Calculate a vector of uniform resolution in the units of the coordinate !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: nk - character(len=*), intent(in) :: coordMode - real, intent(in) :: maxDepth, rhoLight, rhoHeavy - real :: uniformResolution(nk) + integer, intent(in) :: nk !< Number of cells in source grid + character(len=*), intent(in) :: coordMode !< A string indicating the coordinate mode. + !! See the documenttion for regrid_consts + !! for the recognized values. + real, intent(in) :: maxDepth !< The range of the grid values in some modes + real, intent(in) :: rhoLight !< The minimum value of the grid in RHO mode + real, intent(in) :: rhoHeavy !< The maximum value of the grid in RHO mode + + real :: uniformResolution(nk) !< The returned uniform resolution grid. ! Local variables integer :: scheme @@ -1871,9 +1911,13 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) end function uniformResolution +!> Initialize the coordinate resolutions by calling the appropriate initialization +!! routine for the specified coordinate mode. subroutine initCoord(CS, coord_mode) - type(regridding_CS), intent(inout) :: CS - character(len=*), intent(in) :: coord_mode + type(regridding_CS), intent(inout) :: CS !< Regridding control structure + character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. + !! See the documenttion for regrid_consts + !! for the recognized values. select case (coordinateMode(coord_mode)) case (REGRIDDING_ZSTAR) @@ -1894,11 +1938,10 @@ subroutine initCoord(CS, coord_mode) end subroutine initCoord !------------------------------------------------------------------------------ -! Set the fixed resolution data -!------------------------------------------------------------------------------ +!> Set the fixed resolution data subroutine setCoordinateResolution( dz, CS ) - real, dimension(:), intent(in) :: dz - type(regridding_CS), intent(inout) :: CS + real, dimension(:), intent(in) :: dz !< A vector of vertical grid spacings + type(regridding_CS), intent(inout) :: CS !< Regridding control structure if (size(dz)/=CS%nk) call MOM_error( FATAL, & 'setCoordinateResolution: inconsistent number of levels' ) @@ -1919,7 +1962,7 @@ subroutine set_target_densities_from_GV( GV, CS ) CS%target_density(nz+1) = GV%Rlay(nz)+0.5*(GV%Rlay(nz)-GV%Rlay(nz-1)) do k = 2,nz CS%target_density(k) = CS%target_density(k-1) + CS%coordinateResolution(k) - end do + enddo CS%target_density_set = .true. end subroutine set_target_densities_from_GV @@ -2004,10 +2047,9 @@ end subroutine set_regrid_max_thickness !------------------------------------------------------------------------------ -! Query the fixed resolution data -!------------------------------------------------------------------------------ +!> Query the fixed resolution data function getCoordinateResolution( CS ) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(CS%nk) :: getCoordinateResolution getCoordinateResolution(:) = CS%coordinateResolution(:) @@ -2038,15 +2080,14 @@ function getCoordinateInterfaces( CS ) ! The following line has an "abs()" to allow ferret users to reference ! data by index. It is a temporary work around... :( -AJA getCoordinateInterfaces(:) = abs( getCoordinateInterfaces(:) ) - end if + endif end function getCoordinateInterfaces !------------------------------------------------------------------------------ -! Query the target coordinate units -!------------------------------------------------------------------------------ +!> Query the target coordinate units function getCoordinateUnits( CS ) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure character(len=20) :: getCoordinateUnits select case ( CS%regridding_scheme ) @@ -2068,10 +2109,9 @@ function getCoordinateUnits( CS ) end function getCoordinateUnits !------------------------------------------------------------------------------ -! Query the short name of the coordinate -!------------------------------------------------------------------------------ +!> Query the short name of the coordinate function getCoordinateShortName( CS ) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure character(len=20) :: getCoordinateShortName select case ( CS%regridding_scheme ) @@ -2109,22 +2149,33 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin) type(regridding_CS), intent(inout) :: CS !< Regridding control structure logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells - real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the new grid (m) - real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid + real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the new grid (m) + real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates real, optional, intent(in) :: depth_of_time_filter_shallow !< Depth to start cubic (H units) real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic (H units) real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density - real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost SLight_nkml_min layers (m) - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickess layers at the top of the model - real, optional, intent(in) :: Rho_ml_avg_depth !< Averaging depth over which to determine mixed layer potential density (m) - real, optional, intent(in) :: nlay_ML_to_interior !< Number of layers to offset the mixed layer density to find resolved stratification (nondim) - logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate - real, optional, intent(in) :: halocline_filt_len !< Length scale over which to filter T & S when looking for spuriously unstable water mass profiles (m) - real, optional, intent(in) :: halocline_strat_tol !< Value of the stratification ratio that defines a problematic halocline region. - logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward from the top. - real, optional, intent(in) :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha - logical, optional, intent(in) :: adaptDoMin + real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost SLight_nkml_min layers (m) + integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the top of the model + real, optional, intent(in) :: Rho_ml_avg_depth !< Averaging depth over which to determine mixed layer potential + !! density (m) + real, optional, intent(in) :: nlay_ML_to_interior !< Number of layers to offset the mixed layer density to find + !! resolved stratification (nondim) + logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate + real, optional, intent(in) :: halocline_filt_len !< Length scale over which to filter T & S when looking for + !! spuriously unstable water mass profiles (m) + real, optional, intent(in) :: halocline_strat_tol !< Value of the stratification ratio that defines a problematic + !! halocline region. + logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward + !! from the top. + real, optional, intent(in) :: adaptTimeRatio !< Ratio of the ALE timestep to the grid timescale, ND. + real, optional, intent(in) :: adaptZoom !< Depth of near-surface zooming region, in m. + real, optional, intent(in) :: adaptZoomCoeff !< Coefficient of near-surface zooming diffusivity, ND. + real, optional, intent(in) :: adaptBuoyCoeff !< Coefficient of buoyancy diffusivity, ND. + real, optional, intent(in) :: adaptAlpha !< Scaling factor on optimization tendency, ND. + logical, optional, intent(in) :: adaptDoMin !< If true, make a HyCOM-like mixed layer by + !! preventing interfaces from being shallower than + !! the depths specified by the regridding coordinate. if (present(interp_scheme)) call set_interp_scheme(CS%interp_CS, interp_scheme) if (present(boundary_extrapolation)) call set_interp_extrap(CS%interp_CS, boundary_extrapolation) @@ -2154,7 +2205,8 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(min_thickness)) call set_sigma_params(CS%sigma_CS, min_thickness=min_thickness) case (REGRIDDING_RHO) if (present(min_thickness)) call set_rho_params(CS%rho_CS, min_thickness=min_thickness) - if (present(integrate_downward_for_e)) call set_rho_params(CS%rho_CS, integrate_downward_for_e=integrate_downward_for_e) + if (present(integrate_downward_for_e)) & + call set_rho_params(CS%rho_CS, integrate_downward_for_e=integrate_downward_for_e) if (associated(CS%rho_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & call set_rho_params(CS%rho_CS, interp_CS=CS%interp_CS) case (REGRIDDING_HYCOM1) @@ -2191,35 +2243,37 @@ integer function get_regrid_size(CS) end function get_regrid_size +!> This returns a copy of the zlike_CS stored in the regridding control structure. function get_zlike_CS(CS) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure type(zlike_CS) :: get_zlike_CS get_zlike_CS = CS%zlike_CS end function get_zlike_CS +!> This returns a copy of the sigma_CS stored in the regridding control structure. function get_sigma_CS(CS) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure type(sigma_CS) :: get_sigma_CS get_sigma_CS = CS%sigma_CS end function get_sigma_CS +!> This returns a copy of the rho_CS stored in the regridding control structure. function get_rho_CS(CS) - type(regridding_CS), intent(in) :: CS + type(regridding_CS), intent(in) :: CS !< Regridding control structure type(rho_CS) :: get_rho_CS get_rho_CS = CS%rho_CS end function get_rho_CS !------------------------------------------------------------------------------ -! Return coordinate-derived thicknesses for fixed coordinate systems -!------------------------------------------------------------------------------ +!> Return coordinate-derived thicknesses for fixed coordinate systems function getStaticThickness( CS, SSH, depth ) - type(regridding_CS), intent(in) :: CS - real, intent(in) :: SSH - real, intent(in) :: depth - real, dimension(CS%nk) :: getStaticThickness + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, intent(in) :: SSH !< The sea surface height, in the same units as depth + real, intent(in) :: depth !< The maximum depth of the grid, perhaps in m. + real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of depth ! Local integer :: k real :: z, dz diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index a7879ae063..c0620122c1 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -140,7 +140,7 @@ subroutine buildGridFromH(nz, h, x) x(1) = 0.0 do k = 1,nz x(k+1) = x(k) + h(k) - end do + enddo end subroutine buildGridFromH @@ -177,8 +177,7 @@ function isPosSumErrSignificant(n1, sum1, n2, sum2) endif end function isPosSumErrSignificant -!> Remaps column of values u0 on grid h0 to grid h1 -!! assuming the top edge is aligned. +!> 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) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid @@ -197,7 +196,7 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed 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_coefficients !Coefficients of polynomial + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial integer :: k real :: eps, h0tot, h0err, h1tot, h1err, u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err real :: hNeglect, hNeglect_edge @@ -205,14 +204,14 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed 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_coefficients, ppoly_r_E, ppoly_r_S, iMethod, & + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefficients, 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_coefficients, n1, h1, iMethod, & + 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 ) if (CS%check_remapping) then @@ -224,9 +223,11 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed .or. (u1minu0max) ) then write(0,*) 'iMethod = ',iMethod write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' write(0,*) 'U: u0min=',u0min,'u1min=',u1min if (u1minu0max) ) then write(0,*) 'iMethod = ',iMethod write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' write(0,*) 'U: u0min=',u0min,'u1min=',u1min if (u1min Creates polynomial reconstructions of u0 on the source grid h0. -subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & +subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & h_neglect_edge ) - type(remapping_CS), intent(in) :: CS + 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,CS%degree+1), & - intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial + intent(out) :: ppoly_r_coefs !< Coefficients of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial integer, intent(out) :: iMethod !< Integration method @@ -367,7 +370,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & ! Reset polynomial ppoly_r_E(:,:) = 0.0 ppoly_r_S(:,:) = 0.0 - ppoly_r_coefficients(:,:) = 0.0 + ppoly_r_coefs(:,:) = 0.0 iMethod = -999 local_remapping_scheme = CS%remapping_scheme @@ -380,45 +383,45 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & endif select case ( local_remapping_scheme ) case ( REMAPPING_PCM ) - call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefficients) + call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefs) iMethod = INTEGRATION_PCM case ( REMAPPING_PLM ) - call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect) - end if + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect) + endif iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) - end if + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) - end if + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & - ppoly_r_coefficients, h_neglect ) - end if + ppoly_r_coefs, h_neglect ) + endif iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge ) call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & - ppoly_r_coefficients, h_neglect ) - end if + ppoly_r_coefs, h_neglect ) + endif iMethod = INTEGRATION_PQM case default call MOM_error( FATAL, 'MOM_remapping, build_reconstructions_1d: '//& @@ -429,13 +432,13 @@ end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & - ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) + ppoly_r_coefs, ppoly_r_E, ppoly_r_S) 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 integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial + real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefs !< Coefficients of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial ! Local variables @@ -486,11 +489,11 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & endif endif if (problem_detected) then - write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefficients(i0,:) + 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,'(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_coefficients(n,:) + write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) enddo call MOM_error(FATAL, 'MOM_remapping, check_reconstructions_1d: '// & 'Edge values or polynomial coefficients were inconsistent!') @@ -502,13 +505,13 @@ end subroutine check_reconstructions_1d !> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating !! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the !! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. -subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, method, & +subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(n0) !< Source grid widths (size n0) real, intent(in) :: u0(n0) !< Source cell averages (size n0) real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: n1 !< Number of cells in target grid real, intent(in) :: h1(n1) !< Target grid widths (size n1) integer, intent(in) :: method !< Remapping scheme to use @@ -730,7 +733,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h if (h0_eff(i0)>0.) then xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 xb = min(1., xb) ! This is only needed when the total target column is wider than the source column - u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method, i0, xa, xb) + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) else ! Vanished cell xb = 1. u_sub(i_sub) = u0(i0) @@ -741,7 +744,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h write(0,*) 'xa,xb: ',xa,xb write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) - write(0,*) 'Polynomial coeffs: ',ppoly0_coefficients(i0,:) + write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& @@ -836,19 +839,26 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h write(0,*) 'method = ',method write(0,*) 'Source to sub-cells:' write(0,*) 'H: h0tot=',h0tot,'h2tot=',h2tot,'dh=',h2tot-h0tot,'h0err=',h0err,'h2err=',h2err - if (abs(h2tot-h0tot)>h0err+h2err) write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,'adjustment err=',u02_err - if (abs(u2tot-u0tot)>u0err+u2err) write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' + if (abs(h2tot-h0tot)>h0err+h2err) & + write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' + write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,& + 'adjustment err=',u02_err + if (abs(u2tot-u0tot)>u0err+u2err) & + write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' write(0,*) 'Sub-cells to target:' write(0,*) 'H: h2tot=',h2tot,'h1tot=',h1tot,'dh=',h1tot-h2tot,'h2err=',h2err,'h1err=',h1err - if (abs(h1tot-h2tot)>h2err+h1err) write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' + if (abs(h1tot-h2tot)>h2err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' write(0,*) 'UH: u2tot=',u2tot,'u1tot=',u1tot,'duh=',u1tot-u2tot,'u2err=',u2err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u2tot)>u2err+u1err) write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' + if (abs(u1tot-u2tot)>u2err+u1err) & + write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' write(0,*) 'Source to target:' write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' write(0,*) 'U: u0min=',u0min,'u1min=',u1min,'u2min=',u2min if (u1min Returns the average value of a reconstruction within a single source cell, i0, !! between the non-dimensional positions xa and xb (xa<=xb) with dimensional !! separation dh. -real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method, i0, xa, xb) +real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: u0(:) !< Cell means - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: method !< Remapping scheme to use integer, intent(in) :: i0 !< Source cell index real, intent(in) :: xa !< Non-dimensional start position within source cell @@ -927,8 +937,8 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = u0(i0) case ( INTEGRATION_PLM ) u_ave = ( & - ppoly0_coefficients(i0,1) & - + ppoly0_coefficients(i0,2) * 0.5 * ( xb + xa ) ) + ppoly0_coefs(i0,1) & + + ppoly0_coefs(i0,2) * 0.5 * ( xb + xa ) ) case ( INTEGRATION_PPM ) mx = 0.5 * ( xa + xb ) a_L = ppoly0_E(i0, 1) @@ -955,21 +965,21 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method xa2pxb2 = xa_2 + xb_2 xapxb = xa + xb u_ave = ( & - ppoly0_coefficients(i0,1) & - + ( ppoly0_coefficients(i0,2) * 0.5 * ( xapxb ) & - + ( ppoly0_coefficients(i0,3) * r_3 * ( xa2pxb2 + xa*xb ) & - + ( ppoly0_coefficients(i0,4) * 0.25* ( xa2pxb2 * xapxb ) & - + ppoly0_coefficients(i0,5) * 0.2 * ( ( xb*xb_2 + xa*xa_2 ) * xapxb + xa_2*xb_2 ) ) ) ) ) + ppoly0_coefs(i0,1) & + + ( ppoly0_coefs(i0,2) * 0.5 * ( xapxb ) & + + ( ppoly0_coefs(i0,3) * r_3 * ( xa2pxb2 + xa*xb ) & + + ( ppoly0_coefs(i0,4) * 0.25* ( xa2pxb2 * xapxb ) & + + ppoly0_coefs(i0,5) * 0.2 * ( ( xb*xb_2 + xa*xa_2 ) * xapxb + xa_2*xb_2 ) ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select else ! dh == 0. select case ( method ) case ( INTEGRATION_PCM ) - u_ave = ppoly0_coefficients(i0,1) + u_ave = ppoly0_coefs(i0,1) case ( INTEGRATION_PLM ) - !u_ave = ppoly0_coefficients(i0,1) & - ! + xa * ppoly0_coefficients(i0,2) + !u_ave = ppoly0_coefs(i0,1) & + ! + xa * ppoly0_coefs(i0,2) a_L = ppoly0_E(i0, 1) a_R = ppoly0_E(i0, 2) Ya = 1. - xa @@ -979,9 +989,9 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = a_R + Ya * ( a_L - a_R ) endif case ( INTEGRATION_PPM ) - !u_ave = ppoly0_coefficients(i0,1) & - ! + xa * ( ppoly0_coefficients(i0,2) & - ! + xa * ppoly0_coefficients(i0,3) ) + !u_ave = ppoly0_coefs(i0,1) & + ! + xa * ( ppoly0_coefs(i0,2) & + ! + xa * ppoly0_coefs(i0,3) ) a_L = ppoly0_E(i0, 1) a_R = ppoly0_E(i0, 2) u_c = u0(i0) @@ -993,11 +1003,11 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = a_R + Ya * ( ( a_L - a_R ) + a_c * xa ) endif case ( INTEGRATION_PQM ) - u_ave = ppoly0_coefficients(i0,1) & - + xa * ( ppoly0_coefficients(i0,2) & - + xa * ( ppoly0_coefficients(i0,3) & - + xa * ( ppoly0_coefficients(i0,4) & - + xa * ppoly0_coefficients(i0,5) ) ) ) + u_ave = ppoly0_coefs(i0,1) & + + xa * ( ppoly0_coefs(i0,2) & + + xa * ( ppoly0_coefs(i0,3) & + + xa * ( ppoly0_coefs(i0,4) & + + xa * ppoly0_coefs(i0,5) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select @@ -1075,13 +1085,13 @@ end subroutine measure_output_bounds !> Remaps column of values u0 on grid h0 to grid h1 by integrating !! over the projection of each h1 cell onto the h0 grid. -subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & +subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h1, method, u1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid widths (size n0) real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: n1 !< Number of cells in target grid real, intent(in) :: h1(:) !< Target grid widths (size n1) integer, intent(in) :: method !< Remapping scheme to use @@ -1106,10 +1116,10 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & xL = xR xR = xL + h1(iTarget) - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) - end do ! end iTarget loop on target grid cells + enddo ! end iTarget loop on target grid cells end subroutine remapByProjection @@ -1123,19 +1133,20 @@ end subroutine remapByProjection !! where !! F(k) = dx1(k) qAverage !! and where qAverage is the average qOld in the region zOld(k) to zNew(k). -subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & +subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & method, u1, h1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid widths (size n0) - real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: dx1(:) !< Target grid edge positions (size n1+1) - integer :: method !< Remapping scheme to use - real, intent(out) :: u1(:) !< Target cell averages (size n1) - real, optional, intent(out) :: h1(:) !< Target grid widths (size n1) - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) + real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(in) :: n1 !< Number of cells in target grid + real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) + integer, intent(in) :: method !< Remapping scheme to use + real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) + real, dimension(:), & + optional, intent(out) :: h1 !< Target grid widths (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. ! Local variables @@ -1178,7 +1189,7 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & ! hFlux is the positive width of the remapped volume hFlux = abs(dx1(iTarget+1)) - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, hFlux, uAve, jStart, xStart ) ! uAve is the average value of u, independent of sign of dx1 fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 @@ -1195,28 +1206,29 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & if (present(h1)) h1(iTarget) = hNew endif - end do ! end iTarget loop on target grid cells + enddo ! end iTarget loop on target grid cells end subroutine remapByDeltaZ !> Integrate the reconstructed column profile over a single cell -subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & +subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, hC, uAve, jStart, xStart, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid sizes (size n0) - real, intent(in) :: u0(:) !< Source cell averages - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial - integer, intent(in) :: method !< Remapping scheme to use - real, intent(in) :: xL, xR !< Left/right edges of target cell - real, intent(in) :: hC !< Cell width hC = xR - xL - real, intent(out) :: uAve !< Average value on target cell - integer, intent(inout) :: jStart !< The index of the cell to start searching from + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) + real, dimension(:), intent(in) :: u0 !< Source cell averages + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(in) :: method !< Remapping scheme to use + real, intent(in) :: xL !< Left edges of target cell + real, intent(in) :: xR !< Right edges of target cell + real, intent(in) :: hC !< Cell width hC = xR - xL + real, intent(out) :: uAve !< Average value on target cell + integer, intent(inout) :: jStart !< The index of the cell to start searching from !< On exit, contains index of last cell used - real, intent(inout) :: xStart !< The left edge position of cell jStart + real, intent(inout) :: xStart !< The left edge position of cell jStart !< On first entry should be 0. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. ! Local variables @@ -1291,25 +1303,25 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - uAve = ppoly0_coefficients(jL,1) + uAve = ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ppoly0_coefficients(jL,2) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ppoly0_coefs(jL,2) case ( INTEGRATION_PPM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ( ppoly0_coefficients(jL,2) & - + xi0 * ppoly0_coefficients(jL,3) ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ppoly0_coefs(jL,3) ) case ( INTEGRATION_PQM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ( ppoly0_coefficients(jL,2) & - + xi0 * ( ppoly0_coefficients(jL,3) & - + xi0 * ( ppoly0_coefficients(jL,4) & - + xi0 * ppoly0_coefficients(jL,5) ) ) ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ( ppoly0_coefs(jL,3) & + + xi0 * ( ppoly0_coefs(jL,4) & + + xi0 * ppoly0_coefs(jL,5) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select - end if ! end checking whether source cell is vanished + endif ! end checking whether source cell is vanished ! 2. Cell is not vanished else @@ -1360,27 +1372,27 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! coordinates, hence: \int_xL^xR p(x) dx = h \int_xi0^xi1 p(xi) dxi select case ( method ) case ( INTEGRATION_PCM ) - q = ( xR - xL ) * ppoly0_coefficients(jL,1) + q = ( xR - xL ) * ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select @@ -1412,27 +1424,27 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - q = q + ( x0jLr - xL ) * ppoly0_coefficients(jL,1) + q = q + ( x0jLr - xL ) * ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL, 'The selected integration method is invalid' ) end select @@ -1442,8 +1454,8 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, do k = jL+1,jR-1 q = q + h0(k) * u0(k) hAct = hAct + h0(k) - end do - end if + enddo + endif ! Integrate from left boundary of cell jR up to xR xi0 = 0.0 @@ -1457,37 +1469,37 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - q = q + ( xR - x0jRl ) * ppoly0_coefficients(jR,1) + q = q + ( xR - x0jRl ) * ppoly0_coefs(jR,1) case ( INTEGRATION_PLM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ( ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ( ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jR,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jR,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select - end if ! end integration for non-vanished cells + endif ! end integration for non-vanished cells ! The cell average is the integrated value divided by the cell width #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ if (hAct==0.) then - uAve = ppoly0_coefficients(jL,1) + uAve = ppoly0_coefs(jL,1) else uAve = q / hAct endif @@ -1495,7 +1507,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, uAve = q / hC #endif - end if ! end if clause to check if cell is vanished + endif ! endif clause to check if cell is vanished end subroutine integrateReconOnInterval @@ -1602,7 +1614,7 @@ logical function remapping_unit_tests(verbose) data h1 /3*1./ ! 3 uniform layers with total depth of 3 data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 type(remapping_CS) :: CS !< Remapping control structure - real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefficients + real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs integer :: i real :: err, h_neglect, h_neglect_edge logical :: thisTest, v @@ -1649,17 +1661,17 @@ logical function remapping_unit_tests(verbose) thisTest = .false. allocate(ppoly0_E(n0,2)) allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefficients(n0,CS%degree+1)) + allocate(ppoly0_coefs(n0,CS%degree+1)) ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 - ppoly0_coefficients(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10 ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) u1(:) = 0. - call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h1, INTEGRATION_PPM, u1, h_neglect ) do i=1,n1 err=u1(i)-8.*(0.5*real(1+n1)-real(i)) @@ -1670,7 +1682,7 @@ logical function remapping_unit_tests(verbose) thisTest = .false. u1(:) = 0. - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, x1-x0(1:n1+1), & INTEGRATION_PPM, u1, hn1, h_neglect ) if (verbose) write(*,*) 'h1 (by delta)' @@ -1687,7 +1699,7 @@ logical function remapping_unit_tests(verbose) call buildGridFromH(n2, h2, x2) dx2(1:n0+1) = x2(1:n0+1) - x0 dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, dx2, & INTEGRATION_PPM, u2, hn2, h_neglect ) if (verbose) write(*,*) 'h2' @@ -1704,7 +1716,7 @@ logical function remapping_unit_tests(verbose) if (verbose) write(*,*) 'Via sub-cells' thisTest = .false. - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, h2, INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(n2,h2,x2,u2) @@ -1715,11 +1727,11 @@ logical function remapping_unit_tests(verbose) if (thisTest) write(*,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' remapping_unit_tests = remapping_unit_tests .or. thisTest - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(6,h2,x2,u2) - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(3,h2,x2,u2) @@ -1727,126 +1739,128 @@ logical function remapping_unit_tests(verbose) write(*,*) '===== MOM_remapping: new remapping_unit_tests ==================' - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefficients) - allocate(ppoly0_coefficients(5,6)) + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + allocate(ppoly0_coefs(5,6)) allocate(ppoly0_E(5,2)) allocate(ppoly0_S(5,2)) call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:) ) + ppoly0_coefs(1:3,:) ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,4./), 'PCM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & h_neglect=1e-10 ) - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') ! Currently fails due to roundoff - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') ! Currently fails due to roundoff + ! The next two tests currently fail due to roundoff. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges') + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges') ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & h_neglect=1e-10 ) - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') ! Currently fails due to roundoff - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') ! Currently fails due to roundoff + ! The next two tests currently fail due to roundoff. + thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges') + thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges') ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefficients(1:4,:), h_neglect ) + ppoly0_coefs(1:4,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefficients(1:4,:), & + ppoly0_coefs(1:4,:), & 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefficients) + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) if (.not. remapping_unit_tests) write(*,*) 'Pass' diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index a7a7635800..75490bee9f 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -39,9 +39,8 @@ module P1M_functions !------------------------------------------------------------------------------ -! p1m interpolation -!------------------------------------------------------------------------------ -subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) +!> Linearly interpolate between edge values +subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ! ------------------------------------------------------------------------------ ! Linearly interpolate between edge values. ! The resulting piecewise interpolant is stored in 'ppoly'. @@ -62,7 +61,7 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) real, dimension(:), intent(in) :: u !< cell average properties (size N) real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_coefficients !< Potentially modified + real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width @@ -85,18 +84,17 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) u0_l = ppoly_E(k,1) u0_r = ppoly_E(k,2) - ppoly_coefficients(k,1) = u0_l - ppoly_coefficients(k,2) = u0_r - u0_l + ppoly_coef(k,1) = u0_l + ppoly_coef(k,2) = u0_r - u0_l - end do ! end loop on interior cells + enddo ! end loop on interior cells end subroutine P1M_interpolation !------------------------------------------------------------------------------ -! p1m boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) +!> Interpolation by linear polynomials within boundary cells +subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) !------------------------------------------------------------------------------ ! Interpolation by linear polynomials within boundary cells. ! The left and right edge values in the left and right boundary cells, @@ -106,18 +104,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. ! Local variables real :: u0, u1 ! cell averages @@ -145,20 +145,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! by using the edge value in the neighboring cell. u0_r = u0 + 0.5 * slope - if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) .LT. 0.0 ) then + if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) < 0.0 ) then slope = 2.0 * ( ppoly_E(2,1) - u0 ) - end if + endif ! Using the limited slope, the left edge value is reevaluated and ! the interpolant coefficients recomputed - if ( h0 .NE. 0.0 ) then + if ( h0 /= 0.0 ) then ppoly_E(1,1) = u0 - 0.5 * slope else ppoly_E(1,1) = u0 - end if + endif - ppoly_coefficients(1,1) = ppoly_E(1,1) - ppoly_coefficients(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = ppoly_E(1,1) + ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -173,18 +173,18 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) u0_l = u1 - 0.5 * slope - if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) .LT. 0.0 ) then + if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) < 0.0 ) then slope = 2.0 * ( u1 - ppoly_E(N-1,2) ) - end if + endif - if ( h1 .NE. 0.0 ) then + if ( h1 /= 0.0 ) then ppoly_E(N,2) = u1 + 0.5 * slope else ppoly_E(N,2) = u1 - end if + endif - ppoly_coefficients(N,1) = ppoly_E(N,1) - ppoly_coefficients(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = ppoly_E(N,1) + ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) end subroutine P1M_boundary_extrapolation diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index ecc7136ead..3034d2a8b4 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -28,9 +28,9 @@ module P3M_functions contains !------------------------------------------------------------------------------ -! p3m interpolation -! ----------------------------------------------------------------------------- -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & +!> Set up a piecewise cubic cubic interpolation from cell averages and estimated +!! edge slopes and values +subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & h_neglect ) !------------------------------------------------------------------------------ ! Cubic interpolation between edges. @@ -43,12 +43,15 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. @@ -59,15 +62,15 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) + call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) end subroutine P3M_interpolation !------------------------------------------------------------------------------ -! p3m limiter -! ----------------------------------------------------------------------------- -subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) +!> Adust a piecewise cubic reconstruction with a limiter that adjusts the edge +!! values and slopes +subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! The p3m limiter operates as follows: ! @@ -82,12 +85,14 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h. @@ -133,83 +138,83 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect u_c = u(k) h_c = h(k) - if ( k .EQ. 1 ) then + if ( k == 1 ) then h_l = h(k) u_l = u(k) else h_l = h(k-1) u_l = u(k-1) - end if + endif - if ( k .EQ. N ) then + if ( k == N ) then h_r = h(k) u_r = u(k) else h_r = h(k+1) u_r = u(k+1) - end if + endif ! Compute limited slope sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! If the slopes are close to zero in machine precision and in absolute ! value, we set the slope to zero. This prevents asymmetric representation ! near extrema. These expressions are both nondimensional. if ( abs(u1_l*h_c) < eps ) then u1_l = 0.0 - end if + endif if ( abs(u1_r*h_c) < eps ) then u1_r = 0.0 - end if + endif ! The edge slopes are limited from above by the respective ! one-sided slopes - if ( abs(u1_l) .GT. abs(sigma_l) ) then + if ( abs(u1_l) > abs(sigma_l) ) then u1_l = sigma_l - end if + endif - if ( abs(u1_r) .GT. abs(sigma_r) ) then + if ( abs(u1_r) > abs(sigma_r) ) then u1_r = sigma_r - end if + endif ! Build cubic interpolant (compute the coefficients) - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) ! Check whether cubic is monotonic - monotonic = is_cubic_monotonic( ppoly_coefficients, k ) + monotonic = is_cubic_monotonic( ppoly_coef, k ) ! If cubic is not monotonic, monotonize it by modifiying the ! edge slopes, store the new edge slopes and recompute the ! cubic coefficients - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h_c, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) - end if + endif ! Store edge slopes ppoly_S(k,1) = u1_l ppoly_S(k,2) = u1_r ! Recompute coefficients of cubic - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) - end do ! loop on cells + enddo ! loop on cells end subroutine P3M_limiter !------------------------------------------------------------------------------ -! p3m boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & +!> calculate the edge values and slopes at boundary cells as part of building a +!! piecewise peicewise cubic sub-grid scale profiles +subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) !------------------------------------------------------------------------------ ! The following explanations apply to the left boundary cell. The same @@ -225,12 +230,15 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. @@ -263,14 +271,14 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b / h1 ! derivative evaluated at xi = 0.0, expressed w.r.t. x ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -285,11 +293,11 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Check whether the edge values are monotonic. For example, if the left edge ! value is larger than the right edge value while the slope is positive, the ! edge values are inconsistent and we need to modify the left edge value - if ( (u0_r-u0_l) * slope .LT. 0.0 ) then + if ( (u0_r-u0_l) * slope < 0.0 ) then u0_l = u0_r u1_l = 0.0 u1_r = 0.0 - end if + endif ! Store edge values and slope, build cubic and check monotonicity ppoly_E(i0,1) = u0_l @@ -298,18 +306,18 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ppoly_S(i0,2) = u1_r ! Store edge values and slope, build cubic and check monotonicity - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coefficients ) - monotonic = is_cubic_monotonic( ppoly_coefficients, i0 ) + call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + monotonic = is_cubic_monotonic( ppoly_coef, i0 ) - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h0, u0_l, u0_r, 0.0, slope, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) - end if + endif ! ----- Right boundary ----- i0 = N-1 @@ -321,16 +329,16 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) u1_l = (b + 2*c + 3*d) / ( h0 + hNeglect ) ! derivative evaluated at xi = 1.0 ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -345,11 +353,11 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Check whether the edge values are monotonic. For example, if the right edge ! value is smaller than the left edge value while the slope is positive, the ! edge values are inconsistent and we need to modify the right edge value - if ( (u0_r-u0_l) * slope .LT. 0.0 ) then + if ( (u0_r-u0_l) * slope < 0.0 ) then u0_r = u0_l u1_l = 0.0 u1_r = 0.0 - end if + endif ! Store edge values and slope, build cubic and check monotonicity ppoly_E(i1,1) = u0_l @@ -357,26 +365,25 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coefficients ) - monotonic = is_cubic_monotonic( ppoly_coefficients, i1 ) + call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + monotonic = is_cubic_monotonic( ppoly_coef, i1 ) - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h1, u0_l, u0_r, slope, 0.0, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) - end if + endif end subroutine P3M_boundary_extrapolation !------------------------------------------------------------------------------ -! Build cubic interpolant in cell k -! ----------------------------------------------------------------------------- -subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) +!> Build cubic interpolant in cell k +subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) !------------------------------------------------------------------------------ ! Given edge values and edge slopes, compute coefficients of cubic in cell k. ! @@ -385,11 +392,14 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) !------------------------------------------------------------------------------ ! Arguments - real, dimension(:), intent(in) :: h ! cell widths (size N) - integer, intent(in) :: k - real, dimension(:,:), intent(in) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + real, dimension(:), intent(in) :: h !< cell widths (size N) + integer, intent(in) :: k !< The index of the cell to work on + real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. ! Local variables real :: u0_l, u0_r ! edge values @@ -410,18 +420,17 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) a2 = 3.0 * ( u0_r - u0_l ) - u1_r - 2.0 * u1_l a3 = u1_r + u1_l + 2.0 * ( u0_l - u0_r ) - ppoly_coefficients(k,1) = a0 - ppoly_coefficients(k,2) = a1 - ppoly_coefficients(k,3) = a2 - ppoly_coefficients(k,4) = a3 + ppoly_coef(k,1) = a0 + ppoly_coef(k,2) = a1 + ppoly_coef(k,3) = a2 + ppoly_coef(k,4) = a3 end subroutine build_cubic_interpolant !------------------------------------------------------------------------------ -! Check whether cubic is monotonic -! ----------------------------------------------------------------------------- -integer function is_cubic_monotonic( ppoly_coefficients, k ) +!> Check whether the cubic reconstruction in cell k is monotonic +integer function is_cubic_monotonic( ppoly_coef, k ) !------------------------------------------------------------------------------ ! This function checks whether the cubic curve in cell k is monotonic. ! If so, returns 1. Otherwise, returns 0. @@ -432,8 +441,8 @@ integer function is_cubic_monotonic( ppoly_coefficients, k ) !------------------------------------------------------------------------------ ! Arguments - real, dimension(:,:), intent(in) :: ppoly_coefficients - integer, intent(in) :: k + real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial + integer, intent(in) :: k !< The index of the cell to work on ! Local variables integer :: monotonic ! boolean indicating if monotonic or not @@ -447,10 +456,10 @@ integer function is_cubic_monotonic( ppoly_coefficients, k ) ! to be equal to 0 or 1, respectively eps = 1e-14 - a0 = ppoly_coefficients(k,1) - a1 = ppoly_coefficients(k,2) - a2 = ppoly_coefficients(k,3) - a3 = ppoly_coefficients(k,4) + a0 = ppoly_coef(k,1) + a1 = ppoly_coef(k,2) + a2 = ppoly_coef(k,3) + a3 = ppoly_coef(k,4) a = a1 b = 2.0 * a2 @@ -461,27 +470,27 @@ integer function is_cubic_monotonic( ppoly_coefficients, k ) rho = b*b - 4.0*a*c - if ( rho .GE. 0.0 ) then - if ( abs(c) .GT. 1e-15 ) then + if ( rho >= 0.0 ) then + if ( abs(c) > 1e-15 ) then xi_0 = 0.5 * ( -b - sqrt( rho ) ) / c xi_1 = 0.5 * ( -b + sqrt( rho ) ) / c - else if ( abs(b) .GT. 1e-15 ) then + elseif ( abs(b) > 1e-15 ) then xi_0 = - a / b xi_1 = - a / b - end if + endif ! If one of the roots of the first derivative lies in (0,1), ! the cubic is not monotonic. - if ( ( (xi_0 .GT. eps) .AND. (xi_0 .LT. 1.0-eps) ) .OR. & - ( (xi_1 .GT. eps) .AND. (xi_1 .LT. 1.0-eps) ) ) then + if ( ( (xi_0 > eps) .AND. (xi_0 < 1.0-eps) ) .OR. & + ( (xi_1 > eps) .AND. (xi_1 < 1.0-eps) ) ) then monotonic = 0 else monotonic = 1 - end if + endif else ! there are no real roots --> cubic is monotonic monotonic = 1 - end if + endif ! Set the return value is_cubic_monotonic = monotonic @@ -490,8 +499,7 @@ end function is_cubic_monotonic !------------------------------------------------------------------------------ -! Monotonize cubic curve -! ----------------------------------------------------------------------------- +!> Monotonize a cubic curve by modifying the edge slopes. subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) !------------------------------------------------------------------------------ ! This routine takes care of monotonizing a cubic on [0,1] by modifying the @@ -522,11 +530,14 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r !------------------------------------------------------------------------------ ! Arguments - real, intent(in) :: h ! cell width - real, intent(in) :: u0_l, u0_r ! edge values - real, intent(in) :: sigma_l, sigma_r ! left and right 2nd-order slopes - real, intent(in) :: slope ! limited PLM slope - real, intent(inout) :: u1_l, u1_r ! edge slopes + real, intent(in) :: h !< cell width + real, intent(in) :: u0_l !< left edge value + real, intent(in) :: u0_r !< right edge value + real, intent(in) :: sigma_l !< left 2nd-order slopes + real, intent(in) :: sigma_r !< right 2nd-order slopes + real, intent(in) :: slope !< limited PLM slope + real, intent(inout) :: u1_l !< left edge slopes + real, intent(inout) :: u1_r !< right edge slopes ! Local variables integer :: found_ip @@ -547,13 +558,13 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! If the edge slopes are inconsistent w.r.t. the limited PLM slope, ! set them to zero - if ( u1_l*slope .LE. 0.0 ) then + if ( u1_l*slope <= 0.0 ) then u1_l = 0.0 - end if + endif - if ( u1_r*slope .LE. 0.0 ) then + if ( u1_r*slope <= 0.0 ) then u1_r = 0.0 - end if + endif ! Compute the location of the inflexion point, which is the root ! of the second derivative @@ -564,55 +575,55 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! There is a possible root (and inflexion point) only if a3 is nonzero. ! When a3 is zero, the second derivative of the cubic is constant (the ! cubic degenerates into a parabola) and no inflexion point exists. - if ( a3 .NE. 0.0 ) then + if ( a3 /= 0.0 ) then ! Location of inflexion point xi_ip = - a2 / (3.0 * a3) ! If the inflexion point lies in [0,1], change boolean value - if ( (xi_ip .GE. 0.0) .AND. (xi_ip .LE. 1.0) ) then + if ( (xi_ip >= 0.0) .AND. (xi_ip <= 1.0) ) then found_ip = 1 - end if - end if + endif + endif ! When there is an inflexion point within [0,1], check the slope ! to see if it is consistent with the limited PLM slope. If not, ! decide on which side we want to collapse the inflexion point. ! If the inflexion point lies on one of the edges, the cubic is ! guaranteed to be monotonic - if ( found_ip .EQ. 1 ) then + if ( found_ip == 1 ) then slope_ip = a1 + 2.0*a2*xi_ip + 3.0*a3*xi_ip*xi_ip ! Check whether slope is consistent - if ( slope_ip*slope .LT. 0.0 ) then - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( slope_ip*slope < 0.0 ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if - end if ! found_ip + endif + endif + endif ! found_ip ! At this point, if the cubic is not monotonic, we know where the ! inflexion point should lie. When the cubic is monotonic, both ! 'inflexion_l' and 'inflexion_r' are set to 0 and nothing is to be done. ! Move inflexion point on the left - if ( inflexion_l .EQ. 1 ) then + if ( inflexion_l == 1 ) then u1_l_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_r u1_r_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_l - if ( (u1_l_tmp*slope .LT. 0.0) .AND. (u1_r_tmp*slope .LT. 0.0) ) then + if ( (u1_l_tmp*slope < 0.0) .AND. (u1_r_tmp*slope < 0.0) ) then u1_l = 0.0 u1_r = 3.0 * (u0_r - u0_l) / h - else if (u1_l_tmp*slope .LT. 0.0) then + elseif (u1_l_tmp*slope < 0.0) then u1_r = u1_r_tmp u1_l = 1.5*(u0_r - u0_l)/h - 0.5*u1_r - else if (u1_r_tmp*slope .LT. 0.0) then + elseif (u1_r_tmp*slope < 0.0) then u1_l = u1_l_tmp u1_r = 3.0*(u0_r - u0_l)/h - 2.0*u1_l @@ -622,27 +633,27 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r u1_l = u1_l_tmp u1_r = u1_r_tmp - end if + endif - end if ! end treating case with inflexion point on the left + endif ! end treating case with inflexion point on the left ! Move inflexion point on the right - if ( inflexion_r .EQ. 1 ) then + if ( inflexion_r == 1 ) then u1_l_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_r u1_r_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_l - if ( (u1_l_tmp*slope .LT. 0.0) .AND. (u1_r_tmp*slope .LT. 0.0) ) then + if ( (u1_l_tmp*slope < 0.0) .AND. (u1_r_tmp*slope < 0.0) ) then u1_l = 3.0 * (u0_r - u0_l) / h u1_r = 0.0 - else if (u1_l_tmp*slope .LT. 0.0) then + elseif (u1_l_tmp*slope < 0.0) then u1_r = u1_r_tmp u1_l = 3.0*(u0_r - u0_l)/h - 2.0*u1_r - else if (u1_r_tmp*slope .LT. 0.0) then + elseif (u1_r_tmp*slope < 0.0) then u1_l = u1_l_tmp u1_r = 1.5*(u0_r - u0_l)/h - 0.5*u1_l @@ -652,17 +663,17 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r u1_l = u1_l_tmp u1_r = u1_r_tmp - end if + endif - end if ! end treating case with inflexion point on the right + endif ! end treating case with inflexion point on the right - if ( abs(u1_l*h) .LT. eps ) then + if ( abs(u1_l*h) < eps ) then u1_l = 0.0 - end if + endif - if ( abs(u1_r*h) .LT. eps ) then + if ( abs(u1_r*h) < eps ) then u1_r = 0.0 - end if + endif end subroutine monotonize_cubic diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index b09f6e080e..6d407b0cc5 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -19,9 +19,10 @@ module PCM_functions contains !------------------------------------------------------------------------------ -! pcm_reconstruction -!------------------------------------------------------------------------------ -subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coefficients ) +!> Reconstruction by constant polynomials within each cell. There is nothing to +!! do but this routine is provided to ensure a homogeneous interface +!! throughout the regridding toolbox. +subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) !------------------------------------------------------------------------------ ! Reconstruction by constant polynomials within each cell. There is nothing to ! do but this routine is provided to ensure a homogeneous interface @@ -31,29 +32,31 @@ subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coefficients ) ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the dimension of 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: u ! cell averages - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell averages + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, + !! with the same units as u. ! Local variables integer :: k ! The coefficients of the piecewise constant polynomial are simply ! the cell averages. - ppoly_coefficients(:,1) = u(:) + ppoly_coef(:,1) = u(:) ! The edge values are equal to the cell average do k = 1,N ppoly_E(k,:) = u(k) - end do + enddo end subroutine PCM_reconstruction diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 83eea1518b..12cd558e60 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -21,9 +21,8 @@ module PLM_functions contains !------------------------------------------------------------------------------ -! PLM_reconstruction -! ----------------------------------------------------------------------------- -subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) +!> Reconstruction by linear polynomials within each cell +subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by linear polynomials within each cell. ! @@ -31,21 +30,23 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -101,7 +102,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! Extrema in the mean values require a PCM reconstruction avoid generating ! larger extreme values. slope = 0.0 - end if + endif ! This block tests to see if roundoff causes edge values to be out of bounds u_min = min( u_l, u_c, u_r ) @@ -129,7 +130,7 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ppoly_E(k,1) = u_c - 0.5 * slope ppoly_E(k,2) = u_c + 0.5 * slope - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Boundary cells use PCM. Extrapolation is handled in a later routine. slp(1) = 0. @@ -171,8 +172,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! Store and return edge values and polynomial coefficients. ppoly_E(1,1) = u(1) ppoly_E(1,2) = u(1) - ppoly_coefficients(1,1) = u(1) - ppoly_coefficients(1,2) = 0. + ppoly_coef(1,1) = u(1) + ppoly_coef(1,2) = 0. do k = 2, N-1 slope = sign( mslp(k), slp(k) ) u_l = u(k) - 0.5 * slope ! Left edge value of cell k @@ -194,28 +195,27 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ppoly_E(k,1) = u_l ppoly_E(k,2) = u_r - ppoly_coefficients(k,1) = u_l - ppoly_coefficients(k,2) = ( u_r - u_l ) + ppoly_coef(k,1) = u_l + ppoly_coef(k,2) = ( u_r - u_l ) ! Check to see if this evaluation of the polynomial at x=1 would be ! monotonic w.r.t. the next cell's edge value. If not, scale back! - edge = ppoly_coefficients(k,2) + ppoly_coefficients(k,1) + edge = ppoly_coef(k,2) + ppoly_coef(k,1) e_r = u(k+1) - 0.5 * sign( mslp(k+1), slp(k+1) ) if ( (edge-u(k))*(e_r-edge)<0.) then - ppoly_coefficients(k,2) = ppoly_coefficients(k,2) * almost_one + ppoly_coef(k,2) = ppoly_coef(k,2) * almost_one endif enddo ppoly_E(N,1) = u(N) ppoly_E(N,2) = u(N) - ppoly_coefficients(N,1) = u(N) - ppoly_coefficients(N,2) = 0. + ppoly_coef(N,1) = u(N) + ppoly_coef(N,2) = 0. end subroutine PLM_reconstruction !------------------------------------------------------------------------------ -! plm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) +!> Reconstruction by linear polynomials within boundary cells +subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by linear polynomials within boundary cells. ! The left and right edge values in the left and right boundary cells, @@ -227,21 +227,23 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables real :: u0, u1 ! cell averages @@ -270,8 +272,8 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ppoly_E(1,1) = u0 - 0.5 * slope ppoly_E(1,2) = u0 + 0.5 * slope - ppoly_coefficients(1,1) = ppoly_E(1,1) - ppoly_coefficients(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = ppoly_E(1,1) + ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -292,8 +294,8 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ppoly_E(N,1) = u1 - 0.5 * slope ppoly_E(N,2) = u1 + 0.5 * slope - ppoly_coefficients(N,1) = ppoly_E(N,1) - ppoly_coefficients(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = ppoly_E(N,1) + ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) end subroutine PLM_boundary_extrapolation diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 4dd6699722..11dabad684 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -25,12 +25,14 @@ module PPM_functions contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) +subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths real, dimension(N), intent(in) :: u !< Cell averages - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values - real, dimension(N,3), intent(inout) :: ppoly_coefficients !< Polynomial coefficients + real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values, + !! with the same units as u. + real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width !! in the same units as h. ! Local variables @@ -47,9 +49,9 @@ subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) edge_r = ppoly_E(k,2) ! Store polynomial coefficients - ppoly_coefficients(k,1) = edge_l - ppoly_coefficients(k,2) = 4.0 * ( u(k) - edge_l ) + 2.0 * ( u(k) - edge_r ) - ppoly_coefficients(k,3) = 3.0 * ( ( edge_r - u(k) ) + ( edge_l - u(k) ) ) + ppoly_coef(k,1) = edge_l + ppoly_coef(k,2) = 4.0 * ( u(k) - edge_l ) + 2.0 * ( u(k) - edge_r ) + ppoly_coef(k,3) = 3.0 * ( ( edge_r - u(k) ) + ( edge_l - u(k) ) ) enddo @@ -127,9 +129,8 @@ end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ -! ppm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) +!> Reconstruction by parabolas within boundary cells +subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -148,21 +149,23 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h. + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: i0, i1 @@ -187,15 +190,15 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b *((h0+hNeglect)/(h1+hNeglect)) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -210,13 +213,13 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n exp1 = (u0_r - u0_l) * (u0 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u0 - 2.0 * u0_r - end if + endif - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u0 - 2.0 * u0_l - end if + endif ppoly_E(i0,1) = u0_l ppoly_E(i0,2) = u0_r @@ -225,9 +228,9 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r c = 3.0 * ( u0_r + u0_l - 2.0 * u0 ) - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c ! ----- Right boundary ----- i0 = N-1 @@ -239,16 +242,16 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) u1_l = (b + 2*c) ! derivative evaluated at xi = 1.0 u1_l = u1_l * ((h1+hNeglect)/(h0+hNeglect)) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -263,13 +266,13 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n exp1 = (u0_r - u0_l) * (u1 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u1 - 2.0 * u0_r - end if + endif - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u1 - 2.0 * u0_l - end if + endif ppoly_E(i1,1) = u0_l ppoly_E(i1,2) = u0_r @@ -278,9 +281,9 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r c = 3.0 * ( u0_r + u0_l - 2.0 * u1 ) - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c end subroutine PPM_boundary_extrapolation diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index 707cd9f40f..3a4e517e57 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -22,9 +22,8 @@ module PQM_functions contains !------------------------------------------------------------------------------ -! PQM_reconstruction -! ----------------------------------------------------------------------------- -subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) +!> PQM_reconstruction does reconstruction by quartic polynomials within each cell. +subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by quartic polynomials within each cell. ! @@ -37,15 +36,18 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_ !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -75,20 +77,19 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_ e = 30.0 * u(k) + 2.5*h_c*(u1_r - u1_l) - 15.0*(u0_l + u0_r) ! Store coefficients - ppoly_coefficients(k,1) = a - ppoly_coefficients(k,2) = b - ppoly_coefficients(k,3) = c - ppoly_coefficients(k,4) = d - ppoly_coefficients(k,5) = e + ppoly_coef(k,1) = a + ppoly_coef(k,2) = b + ppoly_coef(k,3) = c + ppoly_coef(k,4) = d + ppoly_coef(k,5) = e - end do ! end loop on cells + enddo ! end loop on cells end subroutine PQM_reconstruction !------------------------------------------------------------------------------ -! Limit pqm -! ----------------------------------------------------------------------------- +!> Limit the piecewise quartic method reconstruction subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) !------------------------------------------------------------------------------ ! Standard PQM limiter (White & Adcroft, JCP 2008). @@ -141,7 +142,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! Loop on interior cells to apply the PQM limiter do k = 2,N-1 - !if ( h(k) .lt. 1.0 ) cycle + !if ( h(k) < 1.0 ) cycle inflexion_l = 0 inflexion_r = 0 @@ -166,32 +167,32 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! If one of the slopes has the wrong sign compared with the ! limited PLM slope, it is set equal to the limited PLM slope - if ( u1_l*slope .le. 0.0 ) u1_l = slope - if ( u1_r*slope .le. 0.0 ) u1_r = slope + if ( u1_l*slope <= 0.0 ) u1_l = slope + if ( u1_r*slope <= 0.0 ) u1_r = slope ! Local extremum --> flatten - if ( (u0_r - u_c) * (u_c - u0_l) .le. 0.0) then + if ( (u0_r - u_c) * (u_c - u0_l) <= 0.0) then u0_l = u_c u0_r = u_c u1_l = 0.0 u1_r = 0.0 inflexion_l = -1 inflexion_r = -1 - end if + endif ! Edge values are bounded and averaged when discontinuous and not ! monotonic, edge slopes are consistent and the cell is not an extremum. ! We now need to check and encorce the monotonicity of the quartic within ! the cell - if ( (inflexion_l .EQ. 0) .AND. (inflexion_r .EQ. 0) ) then + if ( (inflexion_l == 0) .AND. (inflexion_r == 0) ) then a = u0_l b = h_c * u1_l @@ -208,7 +209,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) rho = alpha2 * alpha2 - 4.0 * alpha1 * alpha3 ! Check whether inflexion points exist - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) @@ -216,89 +217,89 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 ! Check whether both inflexion points lie in [0,1] - if ( (x1 .GE. 0.0) .AND. (x1 .LE. 1.0) .AND. & - (x2 .GE. 0.0) .AND. (x2 .LE. 1.0) ) then + if ( (x1 >= 0.0) .AND. (x1 <= 1.0) .AND. & + (x2 >= 0.0) .AND. (x2 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b ! Check whether one of the gradients is inconsistent - if ( (gradient1 * slope .LT. 0.0) .OR. & - (gradient2 * slope .LT. 0.0) ) then + if ( (gradient1 * slope < 0.0) .OR. & + (gradient2 * slope < 0.0) ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif ! If both x1 and x2 do not lie in [0,1], check whether ! only x1 lies in [0,1] - else if ( (x1 .GE. 0.0) .AND. (x1 .LE. 1.0) ) then + elseif ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b ! Check whether the gradient is inconsistent - if ( gradient1 * slope .LT. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif ! If x1 does not lie in [0,1], check whether x2 lies in [0,1] - else if ( (x2 .GE. 0.0) .AND. (x2 .LE. 1.0) ) then + elseif ( (x2 >= 0.0) .AND. (x2 <= 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b ! Check whether the gradient is inconsistent - if ( gradient2 * slope .LT. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if + endif + endif - end if ! end checking where the inflexion points lie + endif ! end checking where the inflexion points lie - end if ! end checking if alpha1 != 0 AND rho >= 0 + endif ! end checking if alpha1 != 0 AND rho >= 0 ! If alpha1 is zero, the second derivative of the quartic reduces ! to a straight line - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .AND. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b ! Check whether the gradient is inconsistent - if ( gradient1 * slope .LT. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 - end if - end if ! check slope consistency + endif + endif ! check slope consistency - end if + endif - end if ! end check whether we can find the root of the straight line + endif ! end check whether we can find the root of the straight line - end if ! end checking whether to shift inflexion points + endif ! end checking whether to shift inflexion points ! At this point, we know onto which edge to shift inflexion points - if ( inflexion_l .EQ. 1 ) then + if ( inflexion_l == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge @@ -309,21 +310,21 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the left edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = 5.0 * u_c - 4.0 * u0_l u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) - else if ( u1_r * slope .LT. 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 u1_l = 10.0 * (-u_c + u0_r) / (3.0 * h_c + hNeglect) - end if + endif - else if ( inflexion_r .EQ. 1 ) then + elseif ( inflexion_r == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge @@ -334,21 +335,21 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the right edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) - else if ( u1_r * slope .LT. 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * u_c - 4.0 * u0_r u1_l = 20.0 * ( -u_c + u0_r ) / (h_c + hNeglect) - end if + endif - end if ! clause to check where to collapse inflexion points + endif ! clause to check where to collapse inflexion points ! Save edge values and edge slopes for reconstruction ppoly_E(k,1) = u0_l @@ -356,7 +357,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ppoly_S(k,1) = u1_l ppoly_S(k,2) = u1_r - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Constant reconstruction within boundary cells ppoly_E(1,:) = u(1) @@ -369,9 +370,8 @@ end subroutine PQM_limiter !------------------------------------------------------------------------------ -! pqm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) +!> piecewise quartic method boundary extrapolation +subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -395,11 +395,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. ! Local variables integer :: i0, i1 @@ -421,15 +423,15 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b *(h0/h1) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope - end if + endif ! The right edge value in the boundary cell is taken to be the left ! edge value in the neighboring cell @@ -444,13 +446,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) exp1 = (u0_r - u0_l) * (u0 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u0 - 2.0 * u0_r - end if + endif - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u0 - 2.0 * u0_l - end if + endif ppoly_E(i0,1) = u0_l ppoly_E(i0,2) = u0_r @@ -460,11 +462,11 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) c = 3.0 * ( u0_r + u0_l - 2.0 * u0 ) ! The quartic is reduced to a parabola in the boundary cell - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c - ppoly_coefficients(i0,4) = 0.0 - ppoly_coefficients(i0,5) = 0.0 + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + ppoly_coef(i0,4) = 0.0 + ppoly_coef(i0,5) = 0.0 ! ----- Right boundary ----- i0 = N-1 @@ -476,18 +478,18 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) - e = ppoly_coefficients(i0,5) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + e = ppoly_coef(i0,5) u1_l = (b + 2*c + 3*d + 4*e) ! derivative evaluated at xi = 1.0 u1_l = u1_l * (h1/h0) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope - end if + endif ! The left edge value in the boundary cell is taken to be the right ! edge value in the neighboring cell @@ -502,13 +504,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) exp1 = (u0_r - u0_l) * (u1 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u1 - 2.0 * u0_r - end if + endif - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u1 - 2.0 * u0_l - end if + endif ppoly_E(i1,1) = u0_l ppoly_E(i1,2) = u0_r @@ -518,19 +520,18 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) c = 3.0 * ( u0_r + u0_l - 2.0 * u1 ) ! The quartic is reduced to a parabola in the boundary cell - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c - ppoly_coefficients(i1,4) = 0.0 - ppoly_coefficients(i1,5) = 0.0 + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + ppoly_coef(i1,4) = 0.0 + ppoly_coef(i1,5) = 0.0 end subroutine PQM_boundary_extrapolation !------------------------------------------------------------------------------ -! pqm boundary extrapolation using rational function -! ----------------------------------------------------------------------------- -subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) +!> pqm boundary extrapolation using a rational function +subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -554,15 +555,18 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h. + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: i0, i1 @@ -600,15 +604,15 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! The right edge value and slope of the boundary cell are taken to be the ! left edge value and slope of the adjacent cell - a = ppoly_coefficients(i1,1) - b = ppoly_coefficients(i1,2) + a = ppoly_coef(i1,1) + b = ppoly_coef(i1,2) u0_r = a ! edge value u1_r = b / (h1 + hNeglect) ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and right ! edge value and slope - if (u1_r.ne.0.) then ! HACK by AJA + if (u1_r /= 0.) then ! HACK by AJA beta = 2.0 * ( u0_r - um ) / ( (h0 + hNeglect)*u1_r) - 1.0 else beta = 0. @@ -626,13 +630,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the PLM edge value. If so, keep it and compute left edge slope ! based on the rational function. If not, keep the PLM edge value and ! compute corresponding slope. - if ( abs(um-u0_l) .lt. abs(um-u_plm) ) then + if ( abs(um-u0_l) < abs(um-u_plm) ) then u1_l = 2.0 * ( br - ar*beta) u1_l = u1_l / (h0 + hNeglect) else u0_l = u_plm u1_l = slope / (h0 + hNeglect) - end if + endif ! Monotonize quartic inflexion_l = 0 @@ -651,41 +655,41 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! Check whether inflexion points exist. If so, transform the quartic ! so that both inflexion points coalesce on the left edge. - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 - if ( (x1 .gt. 0.0) .and. (x1 .lt. 1.0) ) then + if ( (x1 > 0.0) .and. (x1 < 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 - if ( (x2 .gt. 0.0) .and. (x2 .lt. 1.0) ) then + if ( (x2 > 0.0) .and. (x2 < 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b - if ( gradient2 * slope .lt. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif - end if + endif - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .and. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .and. (x1 <= 1.0) ) then gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_l = 1 - end if - end if + endif + endif - end if + endif - if ( inflexion_l .eq. 1 ) then + if ( inflexion_l == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge @@ -696,21 +700,21 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the left edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = 5.0 * um - 4.0 * u0_l u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) - else if ( u1_r * slope .LT. 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*um - 3.0*u0_r) / 2.0 u1_l = 10.0 * (-um + u0_r) / (3.0 * h0 + hNeglect ) - end if + endif - end if + endif ! Store edge values, edge slopes and coefficients ppoly_E(i0,1) = u0_l @@ -725,11 +729,11 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff e = 30.0 * um + 2.5*h0*(u1_r - u1_l) - 15.0*(u0_l + u0_r) ! Store coefficients - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c - ppoly_coefficients(i0,4) = d - ppoly_coefficients(i0,5) = e + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + ppoly_coef(i0,4) = d + ppoly_coef(i0,5) = e ! ----- Right boundary (BOTTOM) ----- i0 = N-1 @@ -747,17 +751,17 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! The left edge value and slope of the boundary cell are taken to be the ! right edge value and slope of the adjacent cell - a = ppoly_coefficients(i0,1) - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) - e = ppoly_coefficients(i0,5) + a = ppoly_coef(i0,1) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + e = ppoly_coef(i0,5) u0_l = a + b + c + d + e ! edge value u1_l = (b + 2*c + 3*d + 4*e) / h0 ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and left ! edge value and slope - if (um-u0_l.ne.0.) then ! HACK by AJA + if (um-u0_l /= 0.) then ! HACK by AJA beta = 0.5*h1*u1_l / (um-u0_l) - 1.0 else beta = 0. @@ -766,7 +770,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ar = u0_l ! Right edge value estimate based on rational function - if (1+beta.ne.0.) then ! HACK by AJA + if (1+beta /= 0.) then ! HACK by AJA u0_r = (ar + 2*br + beta*br ) / ((1+beta)*(1+beta)) else u0_r = um + 0.5 * slope ! PLM @@ -779,13 +783,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the PLM edge value. If so, keep it and compute right edge slope ! based on the rational function. If not, keep the PLM edge value and ! compute corresponding slope. - if ( abs(um-u0_r) .lt. abs(um-u_plm) ) then + if ( abs(um-u0_r) < abs(um-u_plm) ) then u1_r = 2.0 * ( br - ar*beta ) / ( (1+beta)*(1+beta)*(1+beta) ) u1_r = u1_r / h1 else u0_r = u_plm u1_r = slope / h1 - end if + endif ! Monotonize quartic inflexion_r = 0 @@ -804,41 +808,41 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! Check whether inflexion points exist. If so, transform the quartic ! so that both inflexion points coalesce on the right edge. - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 - if ( (x1 .gt. 0.0) .and. (x1 .lt. 1.0) ) then + if ( (x1 > 0.0) .and. (x1 < 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 - if ( (x2 .gt. 0.0) .and. (x2 .lt. 1.0) ) then + if ( (x2 > 0.0) .and. (x2 < 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b - if ( gradient2 * slope .lt. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif - end if + endif - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .and. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .and. (x1 <= 1.0) ) then gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_r = 1 - end if - end if + endif + endif - end if + endif - if ( inflexion_r .eq. 1 ) then + if ( inflexion_r == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge @@ -849,21 +853,21 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the right edge - if ( u1_l * slope .lt. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = ( 5.0 * um - 3.0 * u0_l ) / 2.0 u1_r = 10.0 * (um - u0_l) / (3.0 * h1) - else if ( u1_r * slope .lt. 0.0 ) then + elseif ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * um - 4.0 * u0_r u1_l = 20.0 * ( -um + u0_r ) / h1 - end if + endif - end if + endif ! Store edge values, edge slopes and coefficients ppoly_E(i1,1) = u0_l @@ -877,11 +881,11 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff d = -60.0 * um + h1 *(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l e = 30.0 * um + 2.5*h1*(u1_r - u1_l) - 15.0*(u0_l + u0_r) - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c - ppoly_coefficients(i1,4) = d - ppoly_coefficients(i1,5) = e + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + ppoly_coef(i1,4) = d + ppoly_coef(i1,5) = e end subroutine PQM_boundary_extrapolation_v1 diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index dff0638711..b2ae0c6de4 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -12,8 +12,7 @@ module coord_adapt #include -type, public :: adapt_CS - private +type, public :: adapt_CS ; private !> Number of layers/levels integer :: nk @@ -51,8 +50,8 @@ module coord_adapt !> Initialise an adapt_CS with parameters subroutine init_coord_adapt(CS, nk, coordinateResolution) type(adapt_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Nominal near-surface resolution (m) if (associated(CS)) call MOM_error(FATAL, "init_coord_adapt: CS already associated") allocate(CS) @@ -64,7 +63,7 @@ end subroutine init_coord_adapt !> Clean up the coordinate control structure subroutine end_coord_adapt(CS) - type(adapt_CS), pointer :: CS + type(adapt_CS), pointer :: CS !< The control structure for this module ! nothing to do if (.not. associated(CS)) return @@ -72,12 +71,21 @@ subroutine end_coord_adapt(CS) deallocate(CS) end subroutine end_coord_adapt +!> This subtroutine can be used to set the parameters for coord_adapt module subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff, & - adaptBuoyCoeff, adaptDrho0, adaptDoMin) - type(adapt_CS), pointer :: CS - real, optional, intent(in) :: adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff - real, optional, intent(in) :: adaptBuoyCoeff, adaptDrho0 - logical, optional, intent(in) :: adaptDoMin + adaptBuoyCoeff, adaptDrho0, adaptDoMin) + type(adapt_CS), pointer :: CS !< The control structure for this module + real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales + real, optional, intent(in) :: adaptAlpha !< Nondimensional coefficient determining + !! how much optimisation to apply + real, optional, intent(in) :: adaptZoom !< Near-surface zooming depth, in m + real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient + real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient + real, optional, intent(in) :: adaptDrho0 !< Reference density difference for + !! stratification-dependent diffusion + logical, optional, intent(in) :: adaptDoMin !< If true, form a HYCOM1-like mixed layer by + !! preventing interfaces from becoming shallower than + !! the depths set by coordinateResolution if (.not. associated(CS)) call MOM_error(FATAL, "set_adapt_params: CS not associated") @@ -91,14 +99,17 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom end subroutine set_adapt_params subroutine build_adapt_column(CS, G, GV, tv, i, j, zInt, tInt, sInt, h, zNext) - type(adapt_CS), intent(in) :: CS + type(adapt_CS), intent(in) :: CS !< The control structure for this module 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(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - integer, intent(in) :: i, j - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: zInt, tInt, sInt + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + integer, intent(in) :: i, j !< The indices of the column to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: zInt !< Interface heights, in H (m or kg m-2). + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: tInt !< Interface temperatures, in C + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: sInt !< Interface salinities, in psu real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZK_(GV)+1), intent(inout) :: zNext ! updated interface positions + real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions ! Local variables integer :: k, nz diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index b3d2ba3238..aad807b62d 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -10,10 +10,9 @@ module coord_hycom implicit none ; private !> Control structure containing required parameters for the HyCOM coordinate -type, public :: hycom_CS - private +type, public :: hycom_CS ; private - !> Number of layers/levels + !> Number of layers/levels in generated grid integer :: nk !> Nominal near-surface resolution @@ -40,8 +39,8 @@ module coord_hycom subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS) type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in generated grid - real, dimension(:), intent(in) :: coordinateResolution !< Z-space thicknesses (m) - real, dimension(:), intent(in) :: target_density !< Interface target densities (kg/m3) + real, dimension(nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution (m) + real, dimension(nk+1),intent(in) :: target_density !< Interface target densities (kg/m3) type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation if (associated(CS)) call MOM_error(FATAL, "init_coord_hycom: CS already associated!") @@ -55,8 +54,9 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp CS%interp_CS = interp_CS end subroutine init_coord_hycom +!> This subroutine deallocates memory in the control structure for the coord_hycom module subroutine end_coord_hycom(CS) - type(hycom_CS), pointer :: CS + type(hycom_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -67,11 +67,12 @@ subroutine end_coord_hycom(CS) deallocate(CS) end subroutine end_coord_hycom +!> This subroutine can be used to set the parameters for the coord_hycom module subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS) - type(hycom_CS), pointer :: CS - real, optional, dimension(:), intent(in) :: max_interface_depths - real, optional, dimension(:), intent(in) :: max_layer_thickness - type(interp_CS_type), optional, intent(in) :: interp_CS + type(hycom_CS), pointer :: CS !< Coordinate control structure + real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces in m + real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers in m + type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") @@ -99,11 +100,12 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & type(EOS_type), pointer :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom (positive in H) - real, dimension(nz), intent(in) :: T, S !< T and S for column + real, dimension(nz), intent(in) :: T !< Temperature of column (degC) + real, dimension(nz), intent(in) :: S !< Salinity of column (psu) real, dimension(nz), intent(in) :: h !< Layer thicknesses, (in m or H) real, dimension(nz), intent(in) :: p_col !< Layer pressure in Pa - real, dimension(nz+1), intent(in) :: z_col ! Interface positions relative to the surface in H units (m or kg m-2) - real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces + real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface in H units (m or kg m-2) + real, dimension(CS%nk+1), intent(inout) :: z_col_new !< Absolute positions of interfaces real, optional, intent(in) :: zScale !< Scaling factor from the input thicknesses in m !! to desired units for zInterface, perhaps m_to_H. real, optional, intent(in) :: h_neglect !< A negligibly small width for the @@ -115,7 +117,8 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & ! Local variables integer :: k - real, dimension(nz) :: rho_col, h_col_new ! Layer quantities + real, dimension(nz) :: rho_col ! Layer quantities + real, dimension(CS%nk) :: h_col_new ! New layer thicknesses real :: z_scale real :: stretching ! z* stretching, converts z* to z. real :: nominal_z ! Nominal depth of interface is using z* (m or Pa) @@ -139,26 +142,26 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & ! Interpolates for the target interface position with the rho_col profile ! Based on global density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & - CS%target_density, nz, h_col_new, z_col_new, h_neglect, h_neglect_edge) + CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) ! Sweep down the interfaces and make sure that the interface is at least ! as deep as a nominal target z* grid nominal_z = 0. stretching = z_col(nz+1) / depth ! Stretches z* to z - do k = 2, nz+1 + do k = 2, CS%nk+1 nominal_z = nominal_z + (z_scale * CS%coordinateResolution(k-1)) * stretching z_col_new(k) = max( z_col_new(k), nominal_z ) z_col_new(k) = min( z_col_new(k), z_col(nz+1) ) enddo - if (maximum_depths_set .and. maximum_h_set) then ; do k=2,nz + if (maximum_depths_set .and. maximum_h_set) then ; do k=2,CS%nk ! The loop bounds are 2 & nz so the top and bottom interfaces do not move. ! Recall that z_col_new is positive downward. z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K), & z_col_new(K-1) + CS%max_layer_thickness(k-1)) - enddo ; elseif (maximum_depths_set) then ; do K=2,nz + enddo ; elseif (maximum_depths_set) then ; do K=2,CS%nk z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K)) - enddo ; elseif (maximum_h_set) then ; do k=2,nz + enddo ; elseif (maximum_h_set) then ; do k=2,CS%nk z_col_new(K) = min(z_col_new(K), z_col_new(K-1) + CS%max_layer_thickness(k-1)) enddo ; endif end subroutine build_hycom1_column diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index bee6832f77..84bb9e5518 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -11,23 +11,22 @@ module coord_rho implicit none ; private !> Control structure containing required parameters for the rho coordinate -type, public :: rho_CS - private +type, public :: rho_CS ; private !> Number of layers integer :: nk - !> Minimum thickness allowed for layers + !> Minimum thickness allowed for layers, in m real :: min_thickness = 0. - !> Reference pressure for density calculations + !> Reference pressure for density calculations, in Pa real :: ref_pressure !> If true, integrate for interface positions from the top downward. !! If false, integrate from the bottom upward, as does the rest of the model. logical :: integrate_downward_for_e = .false. - !> Nominal density of interfaces + !> Nominal density of interfaces, in kg m-3 real, allocatable, dimension(:) :: target_density !> Interpolation control structure @@ -46,10 +45,10 @@ module coord_rho !> Initialise a rho_CS with pointers to parameters subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) type(rho_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, intent(in) :: ref_pressure - real, dimension(:), intent(in) :: target_density - type(interp_CS_type), intent(in) :: interp_CS + integer, intent(in) :: nk !< Number of layers in the grid + real, intent(in) :: ref_pressure !< Nominal density of interfaces in Pa + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces in kg m-3 + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation if (associated(CS)) call MOM_error(FATAL, "init_coord_rho: CS already associated!") allocate(CS) @@ -61,8 +60,9 @@ subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) CS%interp_CS = interp_CS end subroutine init_coord_rho +!> This subroutine deallocates memory in the control structure for the coord_rho module subroutine end_coord_rho(CS) - type(rho_CS), pointer :: CS + type(rho_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -70,11 +70,15 @@ subroutine end_coord_rho(CS) deallocate(CS) end subroutine end_coord_rho +!> This subroutine can be used to set the parameters for the coord_rho module subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS) - type(rho_CS), pointer :: CS - real, optional, intent(in) :: min_thickness - logical, optional, intent(in) :: integrate_downward_for_e - type(interp_CS_type), optional, intent(in) :: interp_CS + type(rho_CS), pointer :: CS !< Coordinate control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness, in m + logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface + !! positions from the top downward. If false, integrate + !! from the bottom upward, as does the rest of the model. + + type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_rho_params: CS not associated") @@ -119,14 +123,14 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & xTmp(1) = 0.0 do k = 1,count_nonzero_layers xTmp(k+1) = xTmp(k) + h_nv(k) - end do + enddo ! Compute densities on source column p(:) = CS%ref_pressure call calculate_density(T, S, p, densities, 1, nz, eqn_of_state) do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) - end do + enddo ! Based on source column density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, densities, count_nonzero_layers, & @@ -137,10 +141,10 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & call old_inflate_layers_1d(CS%min_thickness, CS%nk, h_new) ! Comment: The following adjustment of h_new, and re-calculation of h_new via x1 needs to be removed - x1(1) = 0.0 ; do k = 1,CS%nk ; x1(k+1) = x1(k) + h_new(k) ; end do + x1(1) = 0.0 ; do k = 1,CS%nk ; x1(k+1) = x1(k) + h_new(k) ; enddo do k = 1,CS%nk h_new(k) = x1(k+1) - x1(k) - end do + enddo else ! count_nonzero_layers <= 1 if (nz == CS%nk) then @@ -227,12 +231,12 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ if ( count_nonzero_layers <= 1 ) then h1(:) = h0(:) exit ! stop iterations here - end if + endif xTmp(1) = 0.0 do k = 1,count_nonzero_layers xTmp(k+1) = xTmp(k) + hTmp(k) - end do + enddo ! Compute densities within current water column call calculate_density( T_tmp, S_tmp, p, densities,& @@ -240,7 +244,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ do k = 1,count_nonzero_layers densities(k) = densities(mapping(k)) - end do + enddo ! One regridding iteration ! Based on global density profile, interpolate to generate a new grid @@ -248,12 +252,12 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ hTmp, xTmp, CS%target_density, nz, h1, x1, h_neglect, h_neglect_edge) call old_inflate_layers_1d( CS%min_thickness, nz, h1 ) - x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; end do + x1(1) = 0.0 ; do k = 1,nz ; x1(k+1) = x1(k) + h1(k) ; enddo ! Remap T and S from previous grid to new grid do k = 1,nz h1(k) = x1(k+1) - x1(k) - end do + enddo call remapping_core_h(remapCS, nz, h0, S, nz, h1, Tmp, h_neglect, h_neglect_edge) S_tmp(:) = Tmp(:) @@ -269,7 +273,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ x0(k) = x0(k-1) + h0(k-1) x1(k) = x1(k-1) + h1(k-1) deviation = deviation + (x0(k)-x1(k))**2 - end do + enddo deviation = sqrt( deviation / (nz-1) ) m = m + 1 @@ -277,7 +281,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ ! Copy final grid onto start grid for next iteration h0(:) = h1(:) - end do ! end regridding iterations + enddo ! end regridding iterations if (CS%integrate_downward_for_e) then zInterface(1) = 0. @@ -326,12 +330,12 @@ subroutine copy_finite_thicknesses(nk, h_in, threshold, nout, h_out, mapping) if (h_out(nout) > thickest_h_out) then thickest_h_out = h_out(nout) k_thickest = nout - end if + endif else ! Add up mass in vanished layers thickness_in_vanished = thickness_in_vanished + h_in(k) - end if - end do + endif + enddo ! No finite layers if (nout <= 1) return @@ -342,14 +346,13 @@ subroutine copy_finite_thicknesses(nk, h_in, threshold, nout, h_out, mapping) end subroutine copy_finite_thicknesses !------------------------------------------------------------------------------ -! Inflate vanished layers to finite (nonzero) width -!------------------------------------------------------------------------------ -subroutine old_inflate_layers_1d( minThickness, N, h ) +!> Inflate vanished layers to finite (nonzero) width +subroutine old_inflate_layers_1d( min_thickness, nk, h ) ! Argument - real, intent(in) :: minThickness - integer, intent(in) :: N - real, intent(inout) :: h(:) + real, intent(in) :: min_thickness !< Minimum allowed thickness, in m + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(inout) :: h !< Layer thicknesses, in m ! Local variable integer :: k @@ -361,42 +364,42 @@ subroutine old_inflate_layers_1d( minThickness, N, h ) ! Count number of nonzero layers count_nonzero_layers = 0 - do k = 1,N - if ( h(k) > minThickness ) then + do k = 1,nk + if ( h(k) > min_thickness ) then count_nonzero_layers = count_nonzero_layers + 1 - end if - end do + endif + enddo ! If all layer thicknesses are greater than the threshold, exit routine - if ( count_nonzero_layers == N ) return + if ( count_nonzero_layers == nk ) return ! If all thicknesses are zero, inflate them all and exit if ( count_nonzero_layers == 0 ) then - do k = 1,N - h(k) = minThickness - end do + do k = 1,nk + h(k) = min_thickness + enddo return - end if + endif ! Inflate zero layers correction = 0.0 - do k = 1,N - if ( h(k) <= minThickness ) then - delta = minThickness - h(k) + do k = 1,nk + if ( h(k) <= min_thickness ) then + delta = min_thickness - h(k) correction = correction + delta h(k) = h(k) + delta - end if - end do + endif + enddo ! Modify thicknesses of nonzero layers to ensure volume conservation maxThickness = h(1) k_found = 1 - do k = 1,N + do k = 1,nk if ( h(k) > maxThickness ) then maxThickness = h(k) k_found = k - end if - end do + endif + enddo h(k_found) = h(k_found) - correction diff --git a/src/ALE/coord_sigma.F90 b/src/ALE/coord_sigma.F90 index c353461e27..bbb6312ba4 100644 --- a/src/ALE/coord_sigma.F90 +++ b/src/ALE/coord_sigma.F90 @@ -8,8 +8,7 @@ module coord_sigma implicit none ; private !> Control structure containing required parameters for the sigma coordinate -type, public :: sigma_CS - private +type, public :: sigma_CS ; private !> Number of levels integer :: nk @@ -28,8 +27,8 @@ module coord_sigma !> Initialise a sigma_CS with pointers to parameters subroutine init_coord_sigma(CS, nk, coordinateResolution) type(sigma_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Nominal coordinate resolution (nondim) if (associated(CS)) call MOM_error(FATAL, "init_coord_sigma: CS already associated!") allocate(CS) @@ -39,8 +38,9 @@ subroutine init_coord_sigma(CS, nk, coordinateResolution) CS%coordinateResolution = coordinateResolution end subroutine init_coord_sigma +!> This subroutine deallocates memory in the control structure for the coord_sigma module subroutine end_coord_sigma(CS) - type(sigma_CS), pointer :: CS + type(sigma_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -48,9 +48,10 @@ subroutine end_coord_sigma(CS) deallocate(CS) end subroutine end_coord_sigma +!> This subroutine can be used to set the parameters for the coord_sigma module subroutine set_sigma_params(CS, min_thickness) - type(sigma_CS), pointer :: CS - real, optional, intent(in) :: min_thickness + type(sigma_CS), pointer :: CS !< Coordinate control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness, in m if (.not. associated(CS)) call MOM_error(FATAL, "set_sigma_params: CS not associated") @@ -59,18 +60,17 @@ end subroutine set_sigma_params !> Build a sigma coordinate column -subroutine build_sigma_column(CS, nz, depth, totalThickness, zInterface) - type(sigma_CS), intent(in) :: CS !< Coordinate control structure - integer, intent(in) :: nz !< Number of levels - real, intent(in) :: depth !< Depth of ocean bottom (positive in m) - real, intent(in) :: totalThickness !< Column thickness (positive in m) - real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces +subroutine build_sigma_column(CS, depth, totalThickness, zInterface) + type(sigma_CS), intent(in) :: CS !< Coordinate control structure + real, intent(in) :: depth !< Depth of ocean bottom (positive in m) + real, intent(in) :: totalThickness !< Column thickness (positive in m) + real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces in m ! Local variables integer :: k - zInterface(nz+1) = -depth - do k = nz,1,-1 + zInterface(CS%nk+1) = -depth + do k = CS%nk,1,-1 zInterface(k) = zInterface(k+1) + (totalThickness * CS%coordinateResolution(k)) ! Adjust interface position to accomodate inflating layers ! without disturbing the interface above diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 93f5b9c393..ba0bdb0326 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -12,13 +12,12 @@ module coord_slight implicit none ; private !> Control structure containing required parameters for the SLight coordinate -type, public :: slight_CS - private +type, public :: slight_CS ; private !> Number of layers/levels integer :: nk - !> Minimum thickness allowed when building the new grid through regridding + !> Minimum thickness allowed when building the new grid through regridding (m) real :: min_thickness !> Reference pressure for potential density calculations (Pa) @@ -35,7 +34,7 @@ module coord_slight !> Number of layers to offset the mixed layer density to find resolved stratification (nondim) real :: nlay_ml_offset = 2.0 - !> The number of fixed-thickess layers at the top of the model + !> The number of fixed-thickness layers at the top of the model integer :: nz_fixed_surface = 2 !> The fixed resolution in the topmost SLight_nkml_min layers (m) @@ -49,16 +48,16 @@ module coord_slight !! unstable water mass profiles, in m. real :: halocline_filter_length = 2.0 - !> A value of the stratification ratio that defines a problematic halocline region. + !> A value of the stratification ratio that defines a problematic halocline region (nondim). real :: halocline_strat_tol = 0.25 - !> Nominal density of interfaces + !> Nominal density of interfaces, in kg m-3. real, allocatable, dimension(:) :: target_density - !> Maximum depths of interfaces + !> Maximum depths of interfaces, in m. real, allocatable, dimension(:) :: max_interface_depths - !> Maximum thicknesses of layers + !> Maximum thicknesses of layers, in m. real, allocatable, dimension(:) :: max_layer_thickness !> Interpolation control structure @@ -72,10 +71,10 @@ module coord_slight !> Initialise a slight_CS with pointers to parameters subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS) type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, intent(in) :: ref_pressure - real, dimension(:), intent(in) :: target_density - type(interp_CS_type), intent(in) :: interp_CS + integer, intent(in) :: nk !< Number of layers in the grid + real, intent(in) :: ref_pressure !< Nominal density of interfaces in Pa + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces in kg m-3 + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation if (associated(CS)) call MOM_error(FATAL, "init_coord_slight: CS already associated!") allocate(CS) @@ -87,8 +86,9 @@ subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS) CS%interp_CS = interp_CS end subroutine init_coord_slight +!> This subroutine deallocates memory in the control structure for the coord_slight module subroutine end_coord_slight(CS) - type(slight_CS), pointer :: CS + type(slight_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -96,23 +96,37 @@ subroutine end_coord_slight(CS) deallocate(CS) end subroutine end_coord_slight +!> This subroutine can be used to set the parameters for the coord_slight module subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & - min_thickness, compressibility_fraction, & - dz_ml_min, nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & - halocline_filter_length, halocline_strat_tol, interp_CS) - type(slight_CS), pointer :: CS - real, optional, dimension(:), intent(in) :: max_interface_depths - real, optional, dimension(:), intent(in) :: max_layer_thickness - real, optional, intent(in) :: min_thickness - real, optional, intent(in) :: compressibility_fraction - real, optional, intent(in) :: dz_ml_min - integer, optional, intent(in) :: nz_fixed_surface - real, optional, intent(in) :: Rho_ML_avg_depth - real, optional, intent(in) :: nlay_ML_offset - logical, optional, intent(in) :: fix_haloclines - real, optional, intent(in) :: halocline_filter_length - real, optional, intent(in) :: halocline_strat_tol - type(interp_CS_type), optional, intent(in) :: interp_CS + min_thickness, compressibility_fraction, dz_ml_min, & + nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & + halocline_filter_length, halocline_strat_tol, interp_CS) + type(slight_CS), pointer :: CS !< Coordinate control structure + real, dimension(:), & + optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces in m + real, dimension(:), & + optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers in m + real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the + !! new grid through regridding, in m + real, optional, intent(in) :: compressibility_fraction !< Fraction (between 0 and 1) of + !! compressibility to add to potential density profiles when + !! interpolating for target grid positions. (nondim) + real, optional, intent(in) :: dz_ml_min !< The fixed resolution in the topmost + !! SLight_nkml_min layers (m) + integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the + !! top of the model + real, optional, intent(in) :: Rho_ML_avg_depth !< Depth over which to average to determine + !! the mixed layer potential density (m) + real, optional, intent(in) :: nlay_ML_offset !< Number of layers to offset the mixed layer + !! density to find resolved stratification (nondim) + logical, optional, intent(in) :: fix_haloclines !< If true, detect regions with much weaker than + !! based on in-situ density, and use a stretched coordinate there. + real, optional, intent(in) :: halocline_filter_length !< A length scale over which to filter T & S + !! when looking for spuriously unstable water mass profiles, in m. + real, optional, intent(in) :: halocline_strat_tol !< A value of the stratification ratio that + !! defines a problematic halocline region (nondim). + type(interp_CS_type), & + optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_slight_params: CS not associated") diff --git a/src/ALE/coord_zlike.F90 b/src/ALE/coord_zlike.F90 index eb3bed51d6..7eafb5d5a6 100644 --- a/src/ALE/coord_zlike.F90 +++ b/src/ALE/coord_zlike.F90 @@ -10,7 +10,7 @@ module coord_zlike !> Control structure containing required parameters for a z-like coordinate type, public :: zlike_CS ; private - !> Number of levels + !> Number of levels to be generated integer :: nk !> Minimum thickness allowed for layers, in the same thickness units that will @@ -28,8 +28,8 @@ module coord_zlike !> Initialise a zlike_CS with pointers to parameters subroutine init_coord_zlike(CS, nk, coordinateResolution) type(zlike_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of levels in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Target coordinate resolution, in m if (associated(CS)) call MOM_error(FATAL, "init_coord_zlike: CS already associated!") allocate(CS) @@ -39,18 +39,20 @@ subroutine init_coord_zlike(CS, nk, coordinateResolution) CS%coordinateResolution = coordinateResolution end subroutine init_coord_zlike +!> Deallocates the zlike control structure subroutine end_coord_zlike(CS) - type(zlike_CS), pointer :: CS + type(zlike_CS), pointer :: CS !< Coordinate control structure - ! nothing to do + ! Nothing to do if (.not. associated(CS)) return deallocate(CS%coordinateResolution) deallocate(CS) end subroutine end_coord_zlike +!> Set parameters in the zlike structure subroutine set_zlike_params(CS, min_thickness) - type(zlike_CS), pointer :: CS - real, optional, intent(in) :: min_thickness + type(zlike_CS), pointer :: CS !< Coordinate control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness, in m if (.not. associated(CS)) call MOM_error(FATAL, "set_zlike_params: CS not associated") @@ -58,17 +60,18 @@ subroutine set_zlike_params(CS, min_thickness) end subroutine set_zlike_params !> Builds a z* coordinate with a minimum thickness -subroutine build_zstar_column(CS, nz, depth, total_thickness, zInterface, & +subroutine build_zstar_column(CS, depth, total_thickness, zInterface, & z_rigid_top, eta_orig, zScale) - type(zlike_CS), intent(in) :: CS !< Coordinate control structure - integer, intent(in) :: nz !< Number of levels - real, intent(in) :: depth !< Depth of ocean bottom (positive in m or H) - real, intent(in) :: total_thickness !< Column thickness (positive in the same units as depth) - real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces - real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (negative in the same units as depth) - real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same units as depth - real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate resolution - !! in m to desired units for zInterface, perhaps m_to_H + type(zlike_CS), intent(in) :: CS !< Coordinate control structure + real, intent(in) :: depth !< Depth of ocean bottom (positive in m or H) + real, intent(in) :: total_thickness !< Column thickness (positive in the same units as depth) + real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces + real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (negative in the + !! same units as depth) + real, optional, intent(in) :: eta_orig !< The actual original height of the top in the + !! same units as depth + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate resolution + !! in m to desired units for zInterface, perhaps m_to_H ! Local variables real :: eta, stretching, dh, min_thickness, z0_top, z_star, z_scale integer :: k @@ -77,7 +80,7 @@ subroutine build_zstar_column(CS, nz, depth, total_thickness, zInterface, & z_scale = 1.0 ; if (present(zScale)) z_scale = zScale new_zstar_def = .false. - min_thickness = min( CS%min_thickness, total_thickness/real(nz) ) + min_thickness = min( CS%min_thickness, total_thickness/real(CS%nk) ) z0_top = 0. if (present(z_rigid_top)) then z0_top = z_rigid_top @@ -101,31 +104,31 @@ subroutine build_zstar_column(CS, nz, depth, total_thickness, zInterface, & ! z_star is the notional z* coordinate in absence of upper/lower topography z_star = 0. ! z*=0 at the free-surface zInterface(1) = eta ! The actual position of the top of the column - do k = 2,nz + do k = 2,CS%nk z_star = z_star - CS%coordinateResolution(k-1)*z_scale ! This ensures that z is below a rigid upper surface (ice shelf bottom) zInterface(k) = min( eta + stretching * ( z_star - z0_top ), z0_top ) ! This ensures that the layer in inflated zInterface(k) = min( zInterface(k), zInterface(k-1) - min_thickness ) ! This ensures that z is above or at the topography - zInterface(k) = max( zInterface(k), -depth + real(nz+1-k) * min_thickness ) + zInterface(k) = max( zInterface(k), -depth + real(CS%nk+1-k) * min_thickness ) enddo - zInterface(nz+1) = -depth + zInterface(CS%nk+1) = -depth else ! Integrate down from the top for a notional new grid, ignoring topography ! The starting position is offset by z0_top which, if z0_top<0, will place ! interfaces above the rigid boundary. zInterface(1) = eta - do k = 1,nz + do k = 1,CS%nk dh = stretching * CS%coordinateResolution(k)*z_scale ! Notional grid spacing zInterface(k+1) = zInterface(k) - dh enddo ! Integrating up from the bottom adjusting interface position to accommodate ! inflating layers without disturbing the interface above - zInterface(nz+1) = -depth - do k = nz,1,-1 + zInterface(CS%nk+1) = -depth + do k = CS%nk,1,-1 if ( zInterface(k) < (zInterface(k+1) + min_thickness) ) then zInterface(k) = zInterface(k+1) + min_thickness endif diff --git a/src/ALE/polynomial_functions.F90 b/src/ALE/polynomial_functions.F90 index b0d5d135d5..78c75f53a0 100644 --- a/src/ALE/polynomial_functions.F90 +++ b/src/ALE/polynomial_functions.F90 @@ -21,111 +21,104 @@ module polynomial_functions contains ! ----------------------------------------------------------------------------- -! Pointwise evaluation of a polynomial -! ----------------------------------------------------------------------------- -real function evaluation_polynomial( coefficients, nb_coefficients, x ) +!> Pointwise evaluation of a polynomial at x +real function evaluation_polynomial( coeff, ncoef, x ) + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + integer, intent(in) :: ncoef !< The number of polynomial coefficients + real, intent(in) :: x !< The position at which to evaluate the polynomial ! ----------------------------------------------------------------------------- ! The polynomial is defined by the coefficients contained in the ! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... -! where C refers to the array 'coefficients'. -! The number of coefficients is given by nb_coefficients and x +! where C refers to the array 'coeff'. +! The number of coefficients is given by ncoef and x ! is the coordinate where the polynomial is to be evaluated. ! ! The function returns the value of the polynomial at x. ! ----------------------------------------------------------------------------- ! Arguments - real, dimension(:), intent(in) :: coefficients - integer, intent(in) :: nb_coefficients - real, intent(in) :: x ! Local variables - integer :: k - real :: f ! value of polynomial at x + integer :: k + real :: f ! value of polynomial at x f = 0.0 - do k = 1,nb_coefficients - f = f + coefficients(k) * ( x**(k-1) ) - end do + do k = 1,ncoef + f = f + coeff(k) * ( x**(k-1) ) + enddo evaluation_polynomial = f end function evaluation_polynomial -!> Calculates the first derivative of a polynomial with coefficients as above -!! evaluated at a point x -real function first_derivative_polynomial( coefficients, nb_coefficients, x ) +!> Calculates the first derivative of a polynomial evaluated at a point x +real function first_derivative_polynomial( coeff, ncoef, x ) + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + integer, intent(in) :: ncoef !< The number of polynomial coefficients + real, intent(in) :: x !< The position at which to evaluate the derivative ! ----------------------------------------------------------------------------- ! The polynomial is defined by the coefficients contained in the ! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... -! where C refers to the array 'coefficients'. -! The number of coefficients is given by nb_coefficients and x +! where C refers to the array 'coeff'. +! The number of coefficients is given by ncoef and x ! is the coordinate where the polynomial's derivative is to be evaluated. ! -! The function returns the value of the polynomial at x. +! The function returns the first derivative of the polynomial at x. ! ----------------------------------------------------------------------------- - ! Arguments - real, dimension(:), intent(in) :: coefficients - integer, intent(in) :: nb_coefficients - real, intent(in) :: x - ! Local variables integer :: k real :: f ! value of polynomial at x f = 0.0 - do k = 2,nb_coefficients - f = f + REAL(k-1)*coefficients(k) * ( x**(k-2) ) - end do + do k = 2,ncoef + f = f + REAL(k-1)*coeff(k) * ( x**(k-2) ) + enddo first_derivative_polynomial = f end function first_derivative_polynomial ! ----------------------------------------------------------------------------- -! Exact integration of polynomial of degree n -! ----------------------------------------------------------------------------- -real function integration_polynomial( xi0, xi1, C, n ) +!> Exact integration of polynomial of degree npoly +real function integration_polynomial( xi0, xi1, Coeff, npoly ) + real, intent(in) :: xi0 !< The lower bound of the integral + real, intent(in) :: xi1 !< The lower bound of the integral + real, dimension(:), intent(in) :: Coeff !< The coefficients of the polynomial + integer, intent(in) :: npoly !< The degree of the polynomial ! ----------------------------------------------------------------------------- -! Exact integration of a polynomial of degree n over the interval [xi0,xi1]. -! The array of coefficients (C) must be of size n+1, where n is the degree of -! the polynomial to integrate. +! Exact integration of a polynomial of degree npoly over the interval [xi0,xi1]. +! The array of coefficients (Coeff) must be of size npoly+1. ! ----------------------------------------------------------------------------- - ! Arguments - real, intent(in) :: xi0, xi1 - real, dimension(:), intent(in) :: C - integer, intent(in) :: n - ! Local variables integer :: k real :: integral integral = 0.0 - do k = 1,(n+1) - integral = integral + C(k) * (xi1**k - xi0**k) / real(k) - end do + do k = 1,npoly+1 + integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) + enddo ! !One non-answer-changing way of unrolling the above is: ! k=1 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) -! if (n>=1) then +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) +! if (npoly>=1) then ! k=2 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=2) then +! if (npoly>=2) then ! k=3 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=3) then +! if (npoly>=3) then ! k=4 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=4) then +! if (npoly>=4) then ! k=5 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif ! integration_polynomial = integral diff --git a/src/ALE/regrid_defs.F90 b/src/ALE/regrid_defs.F90 deleted file mode 100644 index 4a3e4fda52..0000000000 --- a/src/ALE/regrid_defs.F90 +++ /dev/null @@ -1,20 +0,0 @@ -module regrid_defs - -! This file is part of MOM6. See LICENSE.md for the license. - -!============================================================================== -! -! Date of creation: 2008.12.15 -! L. White -! -! This module contains the parameters and types used for the -! regridding/remapping. -! -!============================================================================== -implicit none ; public - -! List of reconstruction schemes for pressure gradient calculation -integer, parameter :: PRESSURE_RECONSTRUCTION_PLM = 1 -integer, parameter :: PRESSURE_RECONSTRUCTION_PPM = 2 - -end module regrid_defs diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index f8781aa937..59d36e3e0e 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -32,6 +32,13 @@ module regrid_edge_slopes !------------------------------------------------------------------------------ !> Compute ih4 edge slopes (implicit third order accurate) subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Compute edge slopes based on third-order implicit estimates. Note that ! the estimates are fourth-order accurate on uniform grids @@ -58,15 +65,6 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) ! boundary conditions close the system. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the - !! same units as u divided by the units of h. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j ! loop indexes real :: h0, h1 ! cell widths @@ -118,23 +116,23 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) tri_b(i+1) = a * u(i) + b * u(i+1) - end do ! end loop on cells + enddo ! end loop on cells ! Boundary conditions: left boundary x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + h(i-1) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * ( h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -150,17 +148,17 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + h(N-5+i) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-4+i) * ( h(N-4+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -178,7 +176,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) do i = 2,N edge_slopes(i,1) = tri_x(i) edge_slopes(i-1,2) = tri_x(i) - end do + enddo edge_slopes(1,1) = tri_x(1) edge_slopes(N,2) = tri_x(N+1) @@ -188,6 +186,13 @@ end subroutine edge_slopes_implicit_h3 !------------------------------------------------------------------------------ !> Compute ih5 edge values (implicit fifth order accurate) subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Fifth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -221,15 +226,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) ! on nonuniform meshes turned out to be intractable. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the - !! same units as u divided by the units of h. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j, k ! loop indexes real :: h0, h1, h2, h3 ! cell widths @@ -368,7 +364,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) tri_u(k+1) = beta tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) - end do ! end loop on cells + enddo ! end loop on cells ! Use a right-biased stencil for the second row @@ -485,17 +481,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + h(i-1) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * h(i) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -625,17 +621,17 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + h(N-7+i) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-6+i) * h(N-6+i) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -656,7 +652,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) do i = 2,N edge_slopes(i,1) = tri_x(i) edge_slopes(i-1,2) = tri_x(i) - end do + enddo edge_slopes(1,1) = tri_x(1) edge_slopes(N,2) = tri_x(N+1) diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index fafb873a6c..5fe4700c38 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -43,9 +43,15 @@ module regrid_edge_values contains !------------------------------------------------------------------------------ -! Bound edge values by neighboring cell averages -!------------------------------------------------------------------------------ -subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) +!> Bound edge values by neighboring cell averages +subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Potentially modified edge values, + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ------------------------------------------------------------------------------ ! In this routine, we loop on all cells to bound their left and right ! edge values by the cell averages. That is, the left edge value must lie @@ -57,15 +63,6 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! Therefore, boundary cells are treated as if they were local extrama. ! ------------------------------------------------------------------------------ - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values, - !! with the same units as u. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: k ! loop index integer :: k0, k1, k2 @@ -88,11 +85,11 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! boundary cell and the right neighbor of the right boundary cell ! is assumed to be the same as the right boundary cell. This ! effectively makes boundary cells look like extrema. - if ( k .EQ. 1 ) then + if ( k == 1 ) then k0 = 1 k1 = 1 k2 = 2 - else if ( k .EQ. N ) then + elseif ( k == N ) then k0 = N-1 k1 = N k2 = N @@ -100,7 +97,7 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) k0 = k-1 k1 = k k2 = k+1 - end if + endif ! All cells can now be treated equally h_l = h(k0) @@ -111,18 +108,18 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) u_c = u(k1) u_r = u(k2) - u0_l = edge_values(k,1) - u0_r = edge_values(k,2) + u0_l = edge_val(k,1) + u0_r = edge_val(k,2) sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 - end if + endif ! The limiter must be used in the local coordinate system to each cell. ! Hence, we must multiply the slope by h1. The multiplication by 0.5 is @@ -130,40 +127,38 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! JCP 2008 Eqs 19 and 20) slope = slope * h_c * 0.5 - if ( (u_l-u0_l)*(u0_l-u_c) .LT. 0.0 ) then + if ( (u_l-u0_l)*(u0_l-u_c) < 0.0 ) then u0_l = u_c - sign( min( abs(slope), abs(u0_l-u_c) ), slope ) - end if + endif - if ( (u_r-u0_r)*(u0_r-u_c) .LT. 0.0 ) then + if ( (u_r-u0_r)*(u0_r-u_c) < 0.0 ) then u0_r = u_c + sign( min( abs(slope), abs(u0_r-u_c) ), slope ) - end if + endif ! Finally bound by neighboring cell means in case of round off u0_l = max( min( u0_l, max(u_l, u_c) ), min(u_l, u_c) ) u0_r = max( min( u0_r, max(u_r, u_c) ), min(u_r, u_c) ) ! Store edge values - edge_values(k,1) = u0_l - edge_values(k,2) = u0_r + edge_val(k,1) = u0_l + edge_val(k,2) = u0_r - end do ! loop on interior edges + enddo ! loop on interior edges end subroutine bound_edge_values !------------------------------------------------------------------------------ -! Average discontinuous edge values (systematically) -!------------------------------------------------------------------------------ -subroutine average_discontinuous_edge_values( N, edge_values ) +!> Replace discontinuous collocated edge values with their average +subroutine average_discontinuous_edge_values( N, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(:,:), intent(inout) :: edge_val !< Edge values that may be modified + !! the second index size is 2. ! ------------------------------------------------------------------------------ ! For each interior edge, check whether the edge values are discontinuous. -! If so, compute the average and replace the edge values by the average.! +! If so, compute the average and replace the edge values by the average. ! ------------------------------------------------------------------------------ - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:,:), intent(inout) :: edge_values - ! Local variables integer :: k ! loop index real :: u0_minus ! left value at given edge @@ -174,36 +169,33 @@ subroutine average_discontinuous_edge_values( N, edge_values ) do k = 1,N-1 ! Edge value on the left of the edge - u0_minus = edge_values(k,2) + u0_minus = edge_val(k,2) ! Edge value on the right of the edge - u0_plus = edge_values(k+1,1) + u0_plus = edge_val(k+1,1) - if ( u0_minus .NE. u0_plus ) then + if ( u0_minus /= u0_plus ) then u0_avg = 0.5 * ( u0_minus + u0_plus ) - edge_values(k,2) = u0_avg - edge_values(k+1,1) = u0_avg - end if + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg + endif - end do ! end loop on interior edges + enddo ! end loop on interior edges end subroutine average_discontinuous_edge_values !------------------------------------------------------------------------------ -! Check discontinuous edge values and take average is not monotonic -!------------------------------------------------------------------------------ -subroutine check_discontinuous_edge_values( N, u, edge_values ) +!> Check discontinuous edge values and replace them with their average if not monotonic +subroutine check_discontinuous_edge_values( N, u, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Cell edge values with the same units as u. ! ------------------------------------------------------------------------------ ! For each interior edge, check whether the edge values are discontinuous. ! If so and if they are not monotonic, replace each edge value by their average. ! ------------------------------------------------------------------------------ - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values - ! Local variables integer :: k ! loop index real :: u0_minus ! left value at given edge @@ -216,10 +208,10 @@ subroutine check_discontinuous_edge_values( N, u, edge_values ) do k = 1,N-1 ! Edge value on the left of the edge - u0_minus = edge_values(k,2) + u0_minus = edge_val(k,2) ! Edge value on the right of the edge - u0_plus = edge_values(k+1,1) + u0_plus = edge_val(k+1,1) ! Left cell average um_minus = u(k) @@ -227,21 +219,28 @@ subroutine check_discontinuous_edge_values( N, u, edge_values ) ! Right cell average um_plus = u(k+1) - if ( (u0_plus - u0_minus)*(um_plus - um_minus) .LT. 0.0 ) then + if ( (u0_plus - u0_minus)*(um_plus - um_minus) < 0.0 ) then u0_avg = 0.5 * ( u0_minus + u0_plus ) u0_avg = max( min( u0_avg, max(um_minus, um_plus) ), min(um_minus, um_plus) ) - edge_values(k,2) = u0_avg - edge_values(k+1,1) = u0_avg - end if + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg + endif - end do ! end loop on interior edges + enddo ! end loop on interior edges end subroutine check_discontinuous_edge_values !------------------------------------------------------------------------------ !> Compute h2 edge values (explicit second order accurate) -subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) +subroutine edge_values_explicit_h2( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ------------------------------------------------------------------------------ ! Compute edge values based on second-order explicit estimates. ! These estimates are based on a straight line spanning two cells and evaluated @@ -255,15 +254,6 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) ! Boundary edge values are set to be equal to the boundary cell averages. ! ------------------------------------------------------------------------------ - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: k ! loop index real :: h0, h1 ! cell widths @@ -288,24 +278,31 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) u1 = u(k) ! Compute left edge value - edge_values(k,1) = ( u0*h1 + u1*h0 ) / ( h0 + h1 ) + edge_val(k,1) = ( u0*h1 + u1*h0 ) / ( h0 + h1 ) ! Left edge value of the current cell is equal to right edge ! value of left cell - edge_values(k-1,2) = edge_values(k,1) + edge_val(k-1,2) = edge_val(k,1) - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Boundary edge values are simply equal to the boundary cell averages - edge_values(1,1) = u(1) - edge_values(N,2) = u(N) + edge_val(1,1) = u(1) + edge_val(N,2) = u(N) end subroutine edge_values_explicit_h2 !------------------------------------------------------------------------------ !> Compute h4 edge values (explicit fourth order accurate) -subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) +subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Compute edge values based on fourth-order explicit estimates. ! These estimates are based on a cubic interpolant spanning four cells @@ -325,15 +322,6 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) ! For this fourth-order scheme, at least four cells must exist. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j real :: u0, u1, u2, u3 @@ -387,8 +375,8 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) e = e / ( h0 + h1 + h2 + h3) - edge_values(i,1) = e - edge_values(i-1,2) = e + edge_val(i,1) = e + edge_val(i-1,2) = e #ifdef __DO_SAFETY_CHECKS__ if (e /= e) then @@ -400,36 +388,36 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) endif #endif - end do ! end loop on interior cells + enddo ! end loop on interior cells ! Determine first two edge values f1 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(i-1)) - end do + enddo do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo B(i) = u(i) * max(f1, h(i) ) - end do + enddo call solve_linear_system( A, B, C, 4 ) ! First edge value - edge_values(1,1) = evaluation_polynomial( C, 4, x(1) ) + edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) ! Second edge value - edge_values(1,2) = evaluation_polynomial( C, 4, x(2) ) - edge_values(2,1) = edge_values(1,2) + edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) + edge_val(2,1) = edge_val(1,2) #ifdef __DO_SAFETY_CHECKS__ - if (edge_values(1,1) /= edge_values(1,1) .or. edge_values(1,2) /= edge_values(1,2)) then + if (edge_val(1,1) /= edge_val(1,1) .or. edge_val(1,2) /= edge_val(1,2)) then write(0,*) 'NaN in explicit_edge_h4 at k=',1 write(0,*) 'A=',A write(0,*) 'B=',B @@ -445,38 +433,38 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max(f1, h(N-5+i)) - end do + enddo do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo B(i) = u(N-4+i) * max(f1, h(N-4+i) ) - end do + enddo call solve_linear_system( A, B, C, 4 ) ! Last edge value - edge_values(N,2) = evaluation_polynomial( C, 4, x(5) ) + edge_val(N,2) = evaluation_polynomial( C, 4, x(5) ) ! Second to last edge value - edge_values(N,1) = evaluation_polynomial( C, 4, x(4) ) - edge_values(N-1,2) = edge_values(N,1) + edge_val(N,1) = evaluation_polynomial( C, 4, x(4) ) + edge_val(N-1,2) = edge_val(N,1) #ifdef __DO_SAFETY_CHECKS__ - if (edge_values(N,1) /= edge_values(N,1) .or. edge_values(N,2) /= edge_values(N,2)) then + if (edge_val(N,1) /= edge_val(N,1) .or. edge_val(N,2) /= edge_val(N,2)) then write(0,*) 'NaN in explicit_edge_h4 at k=',N write(0,*) 'A=' do i = 1,4 do j = 1,4 A(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / real(j) - end do + enddo write(0,*) A(i,:) B(i) = u(N-4+i) * ( h(N-4+i) ) - end do + enddo write(0,*) 'B=',B write(0,*) 'C=',C write(0,*) 'h(:N)=',h(N-3:N) @@ -490,7 +478,14 @@ end subroutine edge_values_explicit_h4 !------------------------------------------------------------------------------ !> Compute ih4 edge values (implicit fourth order accurate) -subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) +subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Compute edge values based on fourth-order implicit estimates. ! @@ -515,15 +510,6 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) ! boundary conditions close the system. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j ! loop indexes real :: h0, h1 ! cell widths @@ -575,24 +561,24 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) tri_b(i+1) = a * u(i) + b * u(i+1) - end do ! end loop on cells + enddo ! end loop on cells ! Boundary conditions: left boundary h0 = max( hNeglect, hMinFrac*sum(h(1:4)) ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(i-1) ) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * max( h0, h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -605,17 +591,17 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) x(1) = 0.0 do i = 2,5 x(i) = x(i-1) + max( h0, h(N-5+i) ) - end do + enddo do i = 1,4 do j = 1,4 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-4+i) * max( h0, h(N-4+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 4 ) @@ -627,18 +613,25 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) do i = 2,N - edge_values(i,1) = tri_x(i) - edge_values(i-1,2) = tri_x(i) - end do - edge_values(1,1) = tri_x(1) - edge_values(N,2) = tri_x(N+1) + edge_val(i,1) = tri_x(i) + edge_val(i-1,2) = tri_x(i) + enddo + edge_val(1,1) = tri_x(1) + edge_val(N,2) = tri_x(N+1) end subroutine edge_values_implicit_h4 !------------------------------------------------------------------------------ !> Compute ih6 edge values (implicit sixth order accurate) -subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) +subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Sixth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -672,15 +665,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) ! on nonuniform meshes turned out to be intractable. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j, k ! loop indexes real :: h0, h1, h2, h3 ! cell widths @@ -828,7 +812,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) tri_u(k+1) = beta tri_b(k+1) = a * u(k-1) + b * u(k) + c * u(k+1) + d * u(k+2) - end do ! end loop on cells + enddo ! end loop on cells ! Use a right-biased stencil for the second row @@ -956,17 +940,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(i-1) ) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(i) * max( g, h(i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -1101,17 +1085,17 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) x(1) = 0.0 do i = 2,7 x(i) = x(i-1) + max( g, h(N-7+i) ) - end do + enddo do i = 1,6 do j = 1,6 Asys(i,j) = ( (x(i+1)**j) - (x(i)**j) ) / j - end do + enddo Bsys(i) = u(N-6+i) * max( g, h(N-6+i) ) - end do + enddo call solve_linear_system( Asys, Bsys, Csys, 6 ) @@ -1124,11 +1108,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) do i = 2,N - edge_values(i,1) = tri_x(i) - edge_values(i-1,2) = tri_x(i) - end do - edge_values(1,1) = tri_x(1) - edge_values(N,2) = tri_x(N+1) + edge_val(i,1) = tri_x(i) + edge_val(i-1,2) = tri_x(i) + enddo + edge_val(1,1) = tri_x(1) + edge_val(N,2) = tri_x(N+1) end subroutine edge_values_implicit_h6 diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 6858e0cded..fd445e7318 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -18,8 +18,7 @@ module regrid_interp implicit none ; private -type, public :: interp_CS_type - private +type, public :: interp_CS_type ; private !> The following parameter is only relevant when used with the target !! interface densities regridding scheme. It indicates which interpolation @@ -105,7 +104,7 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_P1M_H4 ) degree = DEGREE_1 @@ -113,11 +112,11 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call edge_values_explicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) - end if + endif call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_P1M_IH4 ) degree = DEGREE_1 @@ -125,18 +124,18 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call edge_values_implicit_h4( n0, h0, densities, ppoly0_E, h_neglect_edge ) else call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) - end if + endif call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if + endif case ( INTERPOLATION_PLM ) degree = DEGREE_1 call PLM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) - end if + endif case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then @@ -146,15 +145,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PPM_IH4 ) if ( n0 >= 4 ) then @@ -164,15 +163,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_P3M_IH4IH3 ) if ( n0 >= 4 ) then @@ -184,15 +183,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, h_neglect_edge ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_P3M_IH6IH5 ) if ( n0 >= 6 ) then @@ -204,15 +203,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call P3M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect, h_neglect_edge ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PQM_IH4IH3 ) if ( n0 >= 4 ) then @@ -224,15 +223,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif case ( INTERPOLATION_PQM_IH6IH5 ) if ( n0 >= 6 ) then @@ -244,15 +243,15 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & if (extrapolate) then call PQM_boundary_extrapolation_v1( n0, h0, densities, ppoly0_E, ppoly0_S, & ppoly0_coefs, h_neglect ) - end if + endif else degree = DEGREE_1 call edge_values_explicit_h2( n0, h0, densities, ppoly0_E, h_neglect_edge ) call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) if (extrapolate) then call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) - end if - end if + endif + endif end select end subroutine regridding_set_ppolys @@ -289,7 +288,7 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & t = target_values(k) x1(k) = get_polynomial_coordinate ( n0, h0, x0, ppoly0_E, ppoly0_coefs, t, degree ) h1(k-1) = x1(k) - x1(k-1) - end do + enddo h1(n1) = x1(n1+1) - x1(n1) end subroutine interpolate_grid @@ -374,7 +373,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( target_value <= ppoly_E(1,1) ) then x_tgt = x_g(1) return ! return because there is no need to look further - end if + endif ! Since discontinuous edge values are allowed, we check whether the target ! value lies between two discontinuous edge values at interior interfaces @@ -384,8 +383,8 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & x_tgt = x_g(k) return ! return because there is no need to look further exit - end if - end do + endif + enddo ! If the target value is outside the range of all values, we ! force the target coordinate to be equal to the lowest or @@ -393,7 +392,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( target_value >= ppoly_E(N,2) ) then x_tgt = x_g(N+1) return ! return because there is no need to look further - end if + endif ! At this point, we know that the target value is bounded and does not ! lie between discontinuous, monotonic edge values. Therefore, @@ -405,8 +404,8 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & ( target_value < ppoly_E(k,2) ) ) then k_found = k exit - end if - end do + endif + enddo ! At this point, 'k_found' should be strictly positive. If not, this is ! a major failure because it means we could not find any target cell @@ -420,14 +419,14 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & 'inconsistent interpolant (perhaps not monotonically '//& 'increasing)' call MOM_error( FATAL, 'Aborting execution' ) - end if + endif ! Reset all polynomial coefficients to 0 and copy those pertaining to ! the found cell a(:) = 0.0 do i = 1,degree+1 a(i) = ppoly_coefs(k_found,i) - end do + enddo ! Guess value to start Newton-Raphson iterations (middle of cell) xi0 = 0.5 @@ -440,7 +439,7 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & if ( ( iter > NR_ITERATIONS ) .OR. & ( abs(delta) < NR_TOLERANCE ) ) then exit - end if + endif numerator = a(1) + a(2)*xi0 + a(3)*xi0*xi0 + a(4)*xi0*xi0*xi0 + & a(5)*xi0*xi0*xi0*xi0 - target_value @@ -460,23 +459,25 @@ function get_polynomial_coordinate ( N, h, x_g, ppoly_E, ppoly_coefs, & xi0 = 0.0 grad = a(2) if ( grad == 0.0 ) xi0 = xi0 + eps - end if + endif if ( xi0 > 1.0 ) then xi0 = 1.0 grad = a(2) + 2*a(3) + 3*a(4) + 4*a(5) if ( grad == 0.0 ) xi0 = xi0 - eps - end if + endif iter = iter + 1 - end do ! end Newton-Raphson iterations + enddo ! end Newton-Raphson iterations x_tgt = x_g(k_found) + xi0 * h(k_found) end function get_polynomial_coordinate !> Numeric value of interpolation_scheme corresponding to scheme name integer function interpolation_scheme(interp_scheme) - character(len=*), intent(in) :: interp_scheme !< Name of interpolation scheme + character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" select case ( uppercase(trim(interp_scheme)) ) case ("P1M_H2"); interpolation_scheme = INTERPOLATION_P1M_H2 @@ -494,18 +495,23 @@ integer function interpolation_scheme(interp_scheme) end select end function interpolation_scheme +!> Store the interpolation_scheme value in the interp_CS based on the input string. subroutine set_interp_scheme(CS, interp_scheme) - type(interp_CS_type), intent(inout) :: CS - character(len=*), intent(in) :: interp_scheme + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" CS%interpolation_scheme = interpolation_scheme(interp_scheme) end subroutine set_interp_scheme -subroutine set_interp_extrap(CS, extrapolation) - type(interp_CS_type), intent(inout) :: CS - logical, intent(in) :: extrapolation +!> Store the boundary_extrapolation value in the interp_CS +subroutine set_interp_extrap(CS, extrap) + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + logical, intent(in) :: extrap !< Indicate whether high-order boundary + !! extrapolation should be used in boundary cells - CS%boundary_extrapolation = extrapolation + CS%boundary_extrapolation = extrap end subroutine set_interp_extrap end module regrid_interp diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index b9e775b1ce..18ef1e5e0b 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -25,21 +25,18 @@ module regrid_solvers contains ! ----------------------------------------------------------------------------- -! Solve the linear system AX = B -! ----------------------------------------------------------------------------- +!> Solve the linear system AX = B by Gaussian elimination subroutine solve_linear_system( A, B, X, system_size ) + real, dimension(:,:), intent(inout) :: A !< The matrix being inverted + real, dimension(:), intent(inout) :: B !< system right-hand side + real, dimension(:), intent(inout) :: X !< solution vector + integer, intent(in) :: system_size !< The size of the system ! ----------------------------------------------------------------------------- ! This routine uses Gauss's algorithm to transform the system's original ! matrix into an upper triangular matrix. Back substitution yields the answer. ! The matrix A must be square and its size must be that of the vectors B and X. ! ----------------------------------------------------------------------------- - ! Arguments - real, dimension(:,:), intent(inout) :: A - real, dimension(:), intent(inout) :: B - real, dimension(:), intent(inout) :: X - integer :: system_size - ! Local variables integer :: i, j, k real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed @@ -59,43 +56,43 @@ subroutine solve_linear_system( A, B, X, system_size ) ! entries of column i in rows below row i. Once a valid ! pivot is found (say in row k), rows i and k are swaped. k = i - do while ( ( .NOT. found_pivot ) .AND. ( k .LE. system_size ) ) + do while ( ( .NOT. found_pivot ) .AND. ( k <= system_size ) ) - if ( abs( A(k,i) ) .GT. eps ) then ! a valid pivot is found + if ( abs( A(k,i) ) > eps ) then ! a valid pivot is found found_pivot = .true. else ! Go to the next row to see ! if there is a valid pivot there k = k + 1 - end if + endif - end do ! end loop to find pivot + enddo ! end loop to find pivot ! If no pivot could be found, the system is singular and we need ! to end the execution if ( .NOT. found_pivot ) then write(0,*) ' A=',A call MOM_error( FATAL, 'The linear system is singular !' ) - end if + endif ! If the pivot is in a row that is different than row i, that is if ! k is different than i, we need to swap those two rows - if ( k .NE. i ) then + if ( k /= i ) then do j = 1,system_size swap_a = A(i,j) A(i,j) = A(k,j) A(k,j) = swap_a - end do + enddo swap_b = B(i) B(i) = B(k) B(k) = swap_b - end if + endif ! Transform pivot to 1 by dividing the entire row ! (right-hand side included) by the pivot pivot = A(i,i) do j = i,system_size A(i,j) = A(i,j) / pivot - end do + enddo B(i) = B(i) / pivot ! #INV: At this point, A(i,i) is a suitable pivot and it is equal to 1 @@ -106,11 +103,11 @@ subroutine solve_linear_system( A, B, X, system_size ) factor = A(k,i) do j = (i+1),system_size ! j is the column index A(k,j) = A(k,j) - factor * A(i,j) - end do + enddo B(k) = B(k) - factor * B(i) - end do + enddo - end do ! end loop on i + enddo ! end loop on i ! Solve system by back substituting @@ -119,26 +116,26 @@ subroutine solve_linear_system( A, B, X, system_size ) X(i) = B(i) do j = (i+1),system_size X(i) = X(i) - A(i,j) * X(j) - end do + enddo X(i) = X(i) / A(i,i) - end do + enddo end subroutine solve_linear_system ! ----------------------------------------------------------------------------- -! Solve the tridiagonal system AX = B -! ----------------------------------------------------------------------------- +!> Solve the tridiagonal system AX = B subroutine solve_tridiagonal_system( Al, Ad, Au, B, X, system_size ) + real, dimension(:), intent(inout) :: Ad !< Maxtix center diagonal + real, dimension(:), intent(inout) :: Al !< Matrix lower diagonal + real, dimension(:), intent(inout) :: Au !< Matrix upper diagonal + real, dimension(:), intent(inout) :: B !< system right-hand side + real, dimension(:), intent(inout) :: X !< solution vector + integer, intent(in) :: system_size !< The size of the system ! ----------------------------------------------------------------------------- ! This routine uses Thomas's algorithm to solve the tridiagonal system AX = B. ! (A is made up of lower, middle and upper diagonals) ! ----------------------------------------------------------------------------- - ! Arguments - real, dimension(:), intent(inout) :: Al, Ad, Au ! lo., mid. and up. diagonals - real, dimension(:), intent(inout) :: B ! system right-hand side - real, dimension(:), intent(inout) :: X ! solution vector - integer, intent(in) :: system_size ! Local variables integer :: k ! Loop index @@ -150,18 +147,18 @@ subroutine solve_tridiagonal_system( Al, Ad, Au, B, X, system_size ) do k = 1,N-1 Al(k+1) = Al(k+1) / Ad(k) Ad(k+1) = Ad(k+1) - Al(k+1) * Au(k) - end do + enddo ! Forward sweep do k = 2,N B(k) = B(k) - Al(k) * B(k-1) - end do + enddo ! Backward sweep X(N) = B(N) / Ad(N) do k = N-1,1,-1 X(k) = ( B(k) - Au(k)*X(k+1) ) / Ad(k) - end do + enddo end subroutine solve_tridiagonal_system diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 5eff86cdcd..bdd1f159cf 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2,7 +2,6 @@ module MOM ! This file is part of MOM6. See LICENSE.md for the license. - ! Infrastructure modules use MOM_debugging, only : MOM_debugging_init, hchksum, uvchksum use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum @@ -10,7 +9,6 @@ module MOM use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_coms, only : reproducing_sum use MOM_coord_initialization, only : MOM_initialize_coord use MOM_diag_mediator, only : diag_mediator_init, enable_averaging use MOM_diag_mediator, only : diag_mediator_infrastructure_init @@ -41,11 +39,11 @@ module MOM use MOM_obsolete_params, only : find_obsolete_params use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS -use MOM_spatial_means, only : global_area_mean, global_area_integral, global_mass_integral +use MOM_spatial_means, only : global_mass_integral use MOM_state_initialization, only : MOM_initialize_state use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) -use MOM_time_manager, only : increment_date +use MOM_time_manager, only : operator(>=), increment_date use MOM_unit_tests, only : unit_tests use coupler_types_mod, only : coupler_type_send_data, coupler_1d_bc_type, coupler_type_spawn @@ -54,14 +52,13 @@ module MOM use MOM_ALE, only : ALE_getCoordinate, ALE_getCoordinateUnits, ALE_writeCoordinateFile use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, ALE_register_diags use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS -use MOM_continuity, only : continuity, continuity_init, continuity_CS, continuity_stencil -use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_init, CoriolisAdv_CS use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end +use MOM_diabatic_driver, only : legacy_diabatic use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics -use MOM_diagnostics, only : register_surface_diags, post_surface_diagnostics -use MOM_diagnostics, only : write_static_fields +use MOM_diagnostics, only : register_surface_diags, write_static_fields +use MOM_diagnostics, only : post_surface_dyn_diags, post_surface_thermo_diags use MOM_diagnostics, only : diagnostics_CS, surface_diag_IDs, transport_diag_IDs use MOM_diag_to_Z, only : calculate_Z_diag_fields, register_Z_tracer use MOM_diag_to_Z, only : MOM_diag_to_Z_init, MOM_diag_to_Z_end, diag_to_Z_CS @@ -76,12 +73,10 @@ module MOM use MOM_dynamics_unsplit_RK2, only : MOM_dyn_unsplit_RK2_CS use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_EOS, only : EOS_init, calculate_density -use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type, set_first_direction use MOM_grid, only : MOM_grid_init, MOM_grid_end use MOM_hor_index, only : hor_index_type, hor_index_init -use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init use MOM_interface_heights, only : find_eta use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init use MOM_lateral_mixing_coeffs, only : calc_resoln_function, VarMix_CS @@ -89,12 +84,10 @@ module MOM use MOM_MEKE_types, only : MEKE_type use MOM_mixed_layer_restrat, only : mixedlayer_restrat, mixedlayer_restrat_init, mixedlayer_restrat_CS use MOM_mixed_layer_restrat, only : mixedlayer_restrat_register_restarts -use MOM_neutral_diffusion, only : neutral_diffusion_CS use MOM_obsolete_diagnostics, only : register_obsolete_diagnostics use MOM_open_boundary, only : ocean_OBC_type, OBC_registry_type use MOM_open_boundary, only : register_temp_salt_segments use MOM_open_boundary, only : open_boundary_register_restarts -use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_init use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS use MOM_sponge, only : init_sponge_diags, sponge_CS @@ -102,7 +95,6 @@ module MOM use MOM_sum_output, only : MOM_sum_output_init, sum_output_CS use MOM_ALE_sponge, only : init_ALE_sponge_diags, ALE_sponge_CS use MOM_thickness_diffuse, only : thickness_diffuse, thickness_diffuse_init, thickness_diffuse_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS use MOM_tracer_advect, only : advect_tracer, tracer_advect_init use MOM_tracer_advect, only : tracer_advect_end, tracer_advect_CS use MOM_tracer_hor_diff, only : tracer_hordiff, tracer_hor_diff_init @@ -119,11 +111,14 @@ module MOM use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : thermo_var_ptrs, vertvisc_type use MOM_variables, only : accel_diag_ptrs, cont_diag_ptrs, ocean_internal_state -use MOM_vert_friction, only : vertvisc, vertvisc_remnant -use MOM_vert_friction, only : vertvisc_limit_vel, vertvisc_init use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_verticalGrid, only : get_thickness_units, get_flux_units, get_tr_flux_units +use MOM_wave_interface, only : wave_parameters_CS, waves_end +use MOM_wave_interface, only : Update_Stokes_Drift +! ODA modules +use MOM_oda_driver_mod, only : ODA_CS, oda, init_oda, oda_end +use MOM_oda_driver_mod, only : set_prior_tracer, set_analysis_time, apply_oda_tracer_increments ! Offline modules use MOM_offline_main, only : offline_transport_CS, offline_transport_init, update_offline_fields use MOM_offline_main, only : insert_offline_main, extract_offline_main, post_offline_convergence_diags @@ -133,7 +128,6 @@ module MOM use MOM_offline_main, only : offline_advection_layer, offline_transport_end use MOM_ALE, only : ale_offline_tracer_final, ALE_main_offline - implicit none ; private #include @@ -150,28 +144,30 @@ module MOM !! the state of the ocean. type, public :: MOM_control_struct ; private real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: & - h, & !< layer thickness (m or kg/m2 (H)) - T, & !< potential temperature (degrees C) - S !< salinity (ppt) + h, & !< layer thickness (m or kg/m2 (H)) + T, & !< potential temperature (degrees C) + S !< salinity (ppt) real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & - u, & !< zonal velocity component (m/s) - uh, & !< uh = u * h * dy at u grid points (m3/s or kg/s) - uhtr !< accumulated zonal thickness fluxes to advect tracers (m3 or kg) + u, & !< zonal velocity component (m/s) + uh, & !< uh = u * h * dy at u grid points (m3/s or kg/s) + uhtr !< accumulated zonal thickness fluxes to advect tracers (m3 or kg) real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & - v, & !< meridional velocity (m/s) - vh, & !< vh = v * h * dx at v grid points (m3/s or kg/s) - vhtr !< accumulated meridional thickness fluxes to advect tracers (m3 or kg) + v, & !< meridional velocity (m/s) + vh, & !< vh = v * h * dx at v grid points (m3/s or kg/s) + vhtr !< accumulated meridional thickness fluxes to advect tracers (m3 or kg) real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - ssh_rint, & !< A running time integral of the sea surface height, in s m. - ave_ssh_ibc, & !< time-averaged (over a forcing time step) sea surface height - !! with a correction for the inverse barometer (meter) - eta_av_bc !< free surface height or column mass time averaged over the last - !! baroclinic dynamics time step (m or kg/m2) - real, pointer, dimension(:,:) :: & - Hml => NULL() !< active mixed layer depth, in m + ssh_rint, & !< A running time integral of the sea surface height, in s m. + ave_ssh_ibc, & !< time-averaged (over a forcing time step) sea surface height + !! with a correction for the inverse barometer (meter) + eta_av_bc !< free surface height or column mass time averaged over the last + !! baroclinic dynamics time step (m or kg/m2) + real, dimension(:,:), pointer :: & + Hml => NULL() !< active mixed layer depth, in m real :: time_in_cycle !< The running time of the current time-stepping cycle - !! in calls that step the dynamics, and also the length of the - !! time integral of ssh_rint, in s. + !! in calls that step the dynamics, and also the length of + !! the time integral of ssh_rint, in s. + real :: time_in_thermo_cycle !< The running time of the current time-stepping + !! cycle in calls that step the thermodynamics, in s. type(ocean_grid_type) :: G !< structure containing metrics and grid info type(verticalGrid_type), pointer :: & @@ -194,14 +190,17 @@ module MOM integer :: ndyn_per_adv = 0 !< Number of calls to dynamics since the last call to advection !! Must be saved if thermo spans coupling? - type(diag_ctrl) :: diag !< structure to regulate diagnostic output timing - type(vertvisc_type) :: visc !< structure containing vertical viscosities, - !! bottom drag viscosities, and related fields - type(MEKE_type), pointer :: MEKE => NULL() !< structure containing fields - !! related to the Mesoscale Eddy Kinetic Energy + type(diag_ctrl) :: diag !< structure to regulate diagnostic output timing + type(vertvisc_type) :: visc !< structure containing vertical viscosities, + !! bottom drag viscosities, and related fields + type(MEKE_type), pointer :: MEKE => NULL() !< structure containing fields + !! related to the Mesoscale Eddy Kinetic Energy logical :: adiabatic !< If true, there are no diapycnal mass fluxes, and no calls !! to routines to calculate or apply diapycnal fluxes. + logical :: use_legacy_diabatic_driver!< If true (default), use the a legacy version of the + !! diabatic subroutine. This is temporary and is needed + !! to avoid change in answers. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. logical :: use_ALE_algorithm !< If true, use the ALE algorithm rather than layered @@ -213,7 +212,6 @@ module MOM !! This is intended for running MOM6 in offline tracer mode type(time_type), pointer :: Time !< pointer to ocean clock - real :: rel_time = 0.0 !< relative time (sec) since start of current execution real :: dt !< (baroclinic) dynamics time step (seconds) real :: dt_therm !< thermodynamics time step (seconds) logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time @@ -235,66 +233,65 @@ module MOM logical :: thickness_diffuse_first !< If true, diffuse thickness before dynamics. logical :: mixedlayer_restrat !< If true, use submesoscale mixed layer restratifying scheme. logical :: useMEKE !< If true, call the MEKE parameterization. + logical :: useWaves !< If true, update Stokes drift real :: dtbt_reset_period !< The time interval in seconds between dynamic !! recalculation of the barotropic time step. If !! this is negative, it is never calculated, and !! if it is 0, it is calculated every step. - real :: dtbt_reset_time !< The last time (as indicated by CS%rel_time) when - !! DTBT was last calculated (sec) + type(time_type) :: dtbt_reset_interval !< A time_time representation of dtbt_reset_period. + type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. type(time_type) :: Z_diag_interval !< amount of time between calculating Z-space diagnostics type(time_type) :: Z_diag_time !< next time to compute Z-space diagnostics - real, pointer, dimension(:,:,:) :: & - h_pre_dyn => NULL(), & !< The thickness before the transports, in H. - T_pre_dyn => NULL(), & !< Temperature before the transports, in degC. - S_pre_dyn => NULL() !< Salinity before the transports, in psu. - type(accel_diag_ptrs) :: ADp !< structure containing pointers to accelerations, - !! for derived diagnostics (e.g., energy budgets) - type(cont_diag_ptrs) :: CDp !< structure containing pointers to continuity equation - !! terms, for derived diagnostics (e.g., energy budgets) - real, pointer, dimension(:,:,:) :: & - u_prev => NULL(), & !< previous value of u stored for diagnostics - v_prev => NULL() !< previous value of v stored for diagnostics - - logical :: interp_p_surf !< If true, linearly interpolate surface pressure - !! over the coupling time step, using specified value - !! at the end of the coupling step. False by default. - logical :: p_surf_prev_set !< If true, p_surf_prev has been properly set from - !! a previous time-step or the ocean restart file. - !! This is only valid when interp_p_surf is true. - real, pointer, dimension(:,:) :: & - p_surf_prev => NULL(), & !< surface pressure (Pa) at end previous call to step_MOM - p_surf_begin => NULL(), & !< surface pressure (Pa) at start of step_MOM_dyn_... - p_surf_end => NULL() !< surface pressure (Pa) at end of step_MOM_dyn_... - - ! Not needed in CS? - real :: missing=-1.0e34 !< missing data value for masked fields + real, dimension(:,:,:), pointer :: & + h_pre_dyn => NULL(), & !< The thickness before the transports, in H. + T_pre_dyn => NULL(), & !< Temperature before the transports, in degC. + S_pre_dyn => NULL() !< Salinity before the transports, in psu. + type(accel_diag_ptrs) :: ADp !< structure containing pointers to accelerations, + !! for derived diagnostics (e.g., energy budgets) + type(cont_diag_ptrs) :: CDp !< structure containing pointers to continuity equation + !! terms, for derived diagnostics (e.g., energy budgets) + real, dimension(:,:,:), pointer :: & + u_prev => NULL(), & !< previous value of u stored for diagnostics + v_prev => NULL() !< previous value of v stored for diagnostics + + logical :: interp_p_surf !< If true, linearly interpolate surface pressure + !! over the coupling time step, using specified value + !! at the end of the coupling step. False by default. + logical :: p_surf_prev_set !< If true, p_surf_prev has been properly set from + !! a previous time-step or the ocean restart file. + !! This is only valid when interp_p_surf is true. + real, dimension(:,:), pointer :: & + p_surf_prev => NULL(), & !< surface pressure (Pa) at end previous call to step_MOM + p_surf_begin => NULL(), & !< surface pressure (Pa) at start of step_MOM_dyn_... + p_surf_end => NULL() !< surface pressure (Pa) at end of step_MOM_dyn_... ! Variables needed to reach between start and finish phases of initialization - logical :: write_IC !< If true, then the initial conditions will be written to file - character(len=120) :: IC_file !< A file into which the initial conditions are - !! written in a new run if SAVE_INITIAL_CONDS is true. + logical :: write_IC !< If true, then the initial conditions will be written to file + character(len=120) :: IC_file !< A file into which the initial conditions are + !! written in a new run if SAVE_INITIAL_CONDS is true. - logical :: calc_rho_for_sea_lev !< If true, calculate rho to convert pressure to sea level + logical :: calc_rho_for_sea_lev !< If true, calculate rho to convert pressure to sea level ! These elements are used to control the calculation and error checking of the surface state - real :: Hmix !< Diagnostic mixed layer thickness over which to - !! average surface tracer properties (in meter) when - !! bulk mixed layer is not used, or a negative value - !! if a bulk mixed layer is being used. - real :: Hmix_UV !< Depth scale over which to average surface flow to - !! feedback to the coupler/driver (m) when - !! bulk mixed layer is not used, or a negative value - !! if a bulk mixed layer is being used. - logical :: check_bad_surface_vals !< If true, scan surface state for ridiculous values. - real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message - real :: bad_val_sst_max !< Maximum SST before triggering bad value message - real :: bad_val_sst_min !< Minimum SST before triggering bad value message - real :: bad_val_sss_max !< Maximum SSS before triggering bad value message - real :: bad_val_column_thickness!< Minimum column thickness before triggering bad value message - + real :: Hmix !< Diagnostic mixed layer thickness over which to + !! average surface tracer properties (in meter) when + !! bulk mixed layer is not used, or a negative value + !! if a bulk mixed layer is being used. + real :: Hmix_UV !< Depth scale over which to average surface flow to + !! feedback to the coupler/driver (m) when + !! bulk mixed layer is not used, or a negative value + !! if a bulk mixed layer is being used. + logical :: check_bad_sfc_vals !< If true, scan surface state for ridiculous values. + real :: bad_val_ssh_max !< Maximum SSH before triggering bad value message + real :: bad_val_sst_max !< Maximum SST before triggering bad value message + real :: bad_val_sst_min !< Minimum SST before triggering bad value message + real :: bad_val_sss_max !< Maximum SSS before triggering bad value message + real :: bad_vol_col_thick !< Minimum column thickness before triggering bad value message + + ! Structures and handles used for diagnostics. type(MOM_diag_IDs) :: IDs type(transport_diag_IDs) :: transport_IDs type(surface_diag_IDs) :: sfc_IDs @@ -331,6 +328,12 @@ module MOM type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() type(offline_transport_CS), pointer :: offline_CSp => NULL() + logical :: ensemble_ocean !< if true, this run is part of a + !! larger ensemble for the purpose of data assimilation + !! or statistical analysis. + type(ODA_CS), pointer :: odaCS => NULL() !< a pointer to the control structure for handling + !! ensemble model state vectors and data assimilation + !! increments and priors end type MOM_control_struct public initialize_MOM, finish_MOM_initialization, MOM_end @@ -360,36 +363,42 @@ module MOM contains - !> This subroutine orchestrates the time stepping of MOM. The adiabatic !! dynamics are stepped by calls to one of the step_MOM_dyn_...routines. !! The action of lateral processes on tracers occur in calls to !! advect_tracer and tracer_hordiff. Vertical mixing and possibly remapping !! occur inside of diabatic. subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & - do_dynamics, do_thermodynamics, start_cycle, end_cycle, cycle_length) - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields - type(surface), intent(inout) :: sfc_state !< surface ocean state - type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< time interval covered by this run segment, in s. - type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM - logical, optional, intent(in) :: do_dynamics !< Present and false, do not do updates due - !! to the dynamics. - logical, optional, intent(in) :: do_thermodynamics !< Present and false, do not do updates due - !! to the thermodynamics or remapping. - logical, optional, intent(in) :: start_cycle !< This indicates whether this call is to be - !! treated as the first call to step_MOM in a - !! time-stepping cycle; missing is like true. - logical, optional, intent(in) :: end_cycle !< This indicates whether this call is to be - !! treated as the last call to step_MOM in a - !! time-stepping cycle; missing is like true. - real, optional, intent(in) :: cycle_length !< The amount of time in a coupled time - !! stepping cycle, in s. + Waves, do_dynamics, do_thermodynamics, start_cycle, & + end_cycle, cycle_length, reset_therm) + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, + !! tracer and mass exchange forcing fields + type(surface), intent(inout) :: sfc_state !< surface ocean state + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + real, intent(in) :: time_interval !< time interval covered by this run segment, in s. + type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM + type(Wave_parameters_CS), & + optional, pointer :: Waves !< An optional pointer to a wave proptery CS + logical, optional, intent(in) :: do_dynamics !< Present and false, do not do updates due + !! to the dynamics. + logical, optional, intent(in) :: do_thermodynamics !< Present and false, do not do updates due + !! to the thermodynamics or remapping. + logical, optional, intent(in) :: start_cycle !< This indicates whether this call is to be + !! treated as the first call to step_MOM in a + !! time-stepping cycle; missing is like true. + logical, optional, intent(in) :: end_cycle !< This indicates whether this call is to be + !! treated as the last call to step_MOM in a + !! time-stepping cycle; missing is like true. + real, optional, intent(in) :: cycle_length !< The amount of time in a coupled time + !! stepping cycle, in s. + logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of + !! thermodynamic quantities should be reset. + !! If missing, this is like start_cycle. ! local - type(ocean_grid_type), pointer :: G ! pointer to a structure containing - ! metrics and related information + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing + ! metrics and related information type(verticalGrid_type), pointer :: GV => NULL() integer :: ntstep ! time steps between tracer updates or diabatic forcing @@ -408,6 +417,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & real :: bbl_time_int ! The amount of time over which the calculated BBL ! properties will apply, for use in diagnostics, or 0 ! if it is not to be calculated anew (sec). + real :: rel_time = 0.0 ! relative time since start of this call (sec). logical :: calc_dtbt ! Indicates whether the dynamically adjusted ! barotropic time step needs to be updated. @@ -421,14 +431,17 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! a stepping cycle (whatever that may mean). logical :: cycle_end ! If true, do calculations and diagnostics that are only done at ! the end of a stepping cycle (whatever that may mean). + logical :: therm_reset ! If true, reset running sums of thermodynamic quantities. real :: cycle_time ! The length of the coupled time-stepping cycle, in s. real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & ssh ! sea surface height, which may be based on eta_av (meter) - real, pointer, dimension(:,:,:) :: & - u, & ! u : zonal velocity component (m/s) - v, & ! v : meridional velocity component (m/s) - h ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) + real, dimension(:,:,:), pointer :: & + u => NULL(), & ! u : zonal velocity component (m/s) + v => NULL(), & ! v : meridional velocity component (m/s) + h => NULL() ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) + real, dimension(:,:), pointer :: & + p_surf => NULL() ! A pointer to the ocean surface pressure, in Pa. real :: I_wt_ssh type(time_type) :: Time_local, end_time_thermo, Time_temp @@ -449,6 +462,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & cycle_start = .true. ; if (present(start_cycle)) cycle_start = start_cycle cycle_end = .true. ; if (present(end_cycle)) cycle_end = end_cycle cycle_time = time_interval ; if (present(cycle_length)) cycle_time = cycle_length + therm_reset = cycle_start ; if (present(reset_therm)) therm_reset = reset_therm call cpu_clock_begin(id_clock_ocean) call cpu_clock_begin(id_clock_other) @@ -462,11 +476,9 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ! First determine the time step that is consistent with this call and an ! integer fraction of time_interval. - if (do_dyn) then n_max = 1 if (time_interval > CS%dt) n_max = ceiling(time_interval/CS%dt - 0.001) - dt = time_interval / real(n_max) thermo_does_span_coupling = (CS%thermo_spans_coupling .and. & (CS%dt_therm > 1.5*cycle_time)) @@ -482,25 +494,16 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & ntstep = MAX(1,MIN(n_max,floor(CS%dt_therm/dt + 0.001))) dt_therm = dt*ntstep endif - else - n_max = 1 - if ((time_interval > CS%dt_therm) .and. (CS%dt_therm > 0.0)) & - n_max = ceiling(time_interval/CS%dt_therm - 0.001) - - dt = time_interval / real(n_max) - dt_therm = dt ; ntstep = 1 - thermo_does_span_coupling = .true. ! This is never used in this case? - endif - if (do_dyn) then - if (.not.ASSOCIATED(forces%p_surf)) CS%interp_p_surf = .false. + if (associated(forces%p_surf)) p_surf => forces%p_surf + if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. - !---------- Initiate group halo pass + !---------- Initiate group halo pass of the forcing fields call cpu_clock_begin(id_clock_pass) call create_group_pass(pass_tau_ustar_psurf, forces%taux, forces%tauy, G%Domain) - if (ASSOCIATED(forces%ustar)) & + if (associated(forces%ustar)) & call create_group_pass(pass_tau_ustar_psurf, forces%ustar, G%Domain) - if (ASSOCIATED(forces%p_surf)) & + if (associated(forces%p_surf)) & call create_group_pass(pass_tau_ustar_psurf, forces%p_surf, G%Domain) if (G%nonblocking_updates) then call start_group_pass(pass_tau_ustar_psurf, G%Domain) @@ -508,16 +511,28 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call do_group_pass(pass_tau_ustar_psurf, G%Domain) endif call cpu_clock_end(id_clock_pass) + else + ! This step only updates the thermodynamics so setting timesteps is simpler. + n_max = 1 + if ((time_interval > CS%dt_therm) .and. (CS%dt_therm > 0.0)) & + n_max = ceiling(time_interval/CS%dt_therm - 0.001) + + dt = time_interval / real(n_max) + dt_therm = dt ; ntstep = 1 + if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf + + if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif - CS%rel_time = 0.0 + if (therm_reset) then + CS%time_in_thermo_cycle = 0.0 + if (associated(CS%tv%frazil)) CS%tv%frazil(:,:) = 0.0 + if (associated(CS%tv%salt_deficit)) CS%tv%salt_deficit(:,:) = 0.0 + if (associated(CS%tv%TempxPmE)) CS%tv%TempxPmE(:,:) = 0.0 + if (associated(CS%tv%internal_heat)) CS%tv%internal_heat(:,:) = 0.0 + endif if (cycle_start) then - if (ASSOCIATED(CS%tv%frazil)) CS%tv%frazil(:,:) = 0.0 - if (ASSOCIATED(CS%tv%salt_deficit)) CS%tv%salt_deficit(:,:) = 0.0 - if (ASSOCIATED(CS%tv%TempxPmE)) CS%tv%TempxPmE(:,:) = 0.0 - if (ASSOCIATED(CS%tv%internal_heat)) CS%tv%internal_heat(:,:) = 0.0 - CS%time_in_cycle = 0.0 do j=js,je ; do i=is,ie ; CS%ssh_rint(i,j) = 0.0 ; enddo ; enddo @@ -534,8 +549,8 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call complete_group_pass(pass_tau_ustar_psurf, G%Domain, clock=id_clock_pass) if (CS%interp_p_surf) then - if (.not.ASSOCIATED(CS%p_surf_end)) allocate(CS%p_surf_end(isd:ied,jsd:jed)) - if (.not.ASSOCIATED(CS%p_surf_begin)) allocate(CS%p_surf_begin(isd:ied,jsd:jed)) + if (.not.associated(CS%p_surf_end)) allocate(CS%p_surf_end(isd:ied,jsd:jed)) + if (.not.associated(CS%p_surf_begin)) allocate(CS%p_surf_begin(isd:ied,jsd:jed)) if (.not.CS%p_surf_prev_set) then do j=jsd,jed ; do i=isd,ied CS%p_surf_prev(i,j) = forces%p_surf(i,j) @@ -545,6 +560,16 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & else CS%p_surf_end => forces%p_surf endif + + if (CS%UseWaves) then + ! Update wave information, which is presently kept static over each call to step_mom + call enable_averaging(time_interval, Time_start + set_time(int(floor(time_interval+0.5))), CS%diag) + call Update_Stokes_Drift(G, GV, Waves, h, forces%ustar) + call disable_averaging(CS%diag) + endif + else ! not do_dyn. + if (CS%UseWaves) & ! Diagnostics are not enabled in this call. + call Update_Stokes_Drift(G, GV, Waves, h, fluxes%ustar) endif if (CS%debug) then @@ -556,12 +581,13 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & endif call cpu_clock_end(id_clock_other) + rel_time = 0.0 do n=1,n_max - CS%rel_time = CS%rel_time + dt ! The relative time at the end of the step. + rel_time = rel_time + dt ! The relative time at the end of the step. ! Set the universally visible time to the middle of the time step. - CS%Time = Time_start + set_time(int(floor(0.5 + CS%rel_time - 0.5*dt))) + CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) ! Set the local time to the end of the time step. - Time_local = Time_start + set_time(int(floor(CS%rel_time+0.5))) + Time_local = Time_start + set_time(int(floor(rel_time+0.5))) if (showCallTree) call callTree_enter("DT cycles (step_MOM) n=",n) @@ -584,29 +610,33 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & dtdia = dt*min(ntstep,n_max-(n-1)) endif - ! If necessary, temporarily reset CS%Time to the center of the period covered - ! by the call to step_MOM_thermo, noting that they begin at the same time. - if (dtdia > dt) CS%Time = CS%Time + set_time(int(floor(0.5*(dtdia-dt) + 0.5))) - - ! The end-time of the diagnostic interval needs to be set ahead if there - ! are multiple dynamic time steps worth of thermodynamics applied here. - end_time_thermo = Time_local + set_time(int(floor(dtdia-dt+0.5))) + end_time_thermo = Time_local + if (dtdia > dt) then + ! If necessary, temporarily reset CS%Time to the center of the period covered + ! by the call to step_MOM_thermo, noting that they begin at the same time. + CS%Time = CS%Time + set_time(int(floor(0.5*(dtdia-dt) + 0.5))) + ! The end-time of the diagnostic interval needs to be set ahead if there + ! are multiple dynamic time steps worth of thermodynamics applied here. + end_time_thermo = Time_local + set_time(int(floor(dtdia-dt+0.5))) + endif ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, end_time_thermo, .true.) + call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, & + end_time_thermo, .true., Waves=Waves) + CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia ! The diabatic processes are now ahead of the dynamics by dtdia. CS%t_dyn_rel_thermo = -dtdia if (showCallTree) call callTree_waypoint("finished diabatic_first (step_MOM)") if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + set_time(int(floor(0.5 + CS%rel_time - 0.5*dt))) + CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) endif ! end of block "(CS%diabatic_first .and. (CS%t_dyn_rel_adv==0.0))" if (do_dyn) then - ! Store pre-dynamics grids for proper diagnostic remapping for transports or advective tendencies - ! If there are more dynamics steps per advective steps (i.e DT_THERM /= DT), this needs to be the - ! stored at the first call + ! Store pre-dynamics grids for proper diagnostic remapping for transports + ! or advective tendencies. If there are more dynamics steps per advective + ! steps (i.e DT_THERM /= DT), this needs to be stored at the first call. if (CS%ndyn_per_adv == 0 .and. CS%t_dyn_rel_adv == 0.) then call diag_copy_diag_to_storage(CS%diag_pre_dyn, h, CS%diag) CS%ndyn_per_adv = CS%ndyn_per_adv + 1 @@ -650,7 +680,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call step_MOM_dynamics(forces, CS%p_surf_begin, CS%p_surf_end, dt, & dt_therm_here, bbl_time_int, CS, & - Time_local, CS%rel_time, n) + Time_local, Waves=Waves) !=========================================================================== ! This is the start of the tracer advection part of the algorithm. @@ -685,11 +715,13 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (dtdia > dt) CS%Time = CS%Time - set_time(int(floor(0.5*(dtdia-dt) + 0.5))) ! Apply diabatic forcing, do mixing, and regrid. - call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, Time_local, .false.) + call step_MOM_thermo(CS, G, GV, u, v, h, CS%tv, fluxes, dtdia, & + Time_local, .false., Waves=Waves) + CS%time_in_thermo_cycle = CS%time_in_thermo_cycle + dtdia CS%t_dyn_rel_thermo = 0.0 if (dtdia > dt) & ! Reset CS%Time to its previous value. - CS%Time = Time_start + set_time(int(floor(0.5 + CS%rel_time - 0.5*dt))) + CS%Time = Time_start + set_time(int(floor(0.5 + rel_time - 0.5*dt))) endif if (do_dyn) then @@ -714,7 +746,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & call enable_averaging(CS%t_dyn_rel_diag, Time_local, CS%diag) call calculate_diagnostic_fields(u, v, h, CS%uh, CS%vh, CS%tv, CS%ADp, & - CS%CDp, fluxes, CS%t_dyn_rel_diag, CS%diag_pre_sync,& + CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& G, GV, CS%diagnostics_CSp) call post_tracer_diagnostics(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) @@ -726,6 +758,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & if (Time_local + set_time(int(0.5*dt_therm)) > CS%Z_diag_time) then call enable_averaging(real(time_type_to_real(CS%Z_diag_interval)), & CS%Z_diag_time, CS%diag) + !### This is the one place where fluxes might used if do_thermo=.false. Is this correct? call calculate_Z_diag_fields(u, v, h, ssh, fluxes%frac_shelf_h, & G, GV, CS%diag_to_Z_CSp) CS%Z_diag_time = CS%Z_diag_time + CS%Z_diag_interval @@ -764,15 +797,30 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & CS%p_surf_prev(i,j) = forces%p_surf(i,j) enddo ; enddo ; endif + if (CS%ensemble_ocean) then + ! update the time for the next analysis step if needed + call set_analysis_time(CS%Time,CS%odaCS) + ! store ensemble vector in odaCS + call set_prior_tracer(CS%Time, G, GV, CS%h, CS%tv, CS%odaCS) + ! call DA interface + call oda(CS%Time,CS%odaCS) + endif + if (showCallTree) call callTree_waypoint("calling extract_surface_state (step_MOM)") call extract_surface_state(CS, sfc_state) ! Do diagnostics that only occur at the end of a complete forcing step. if (cycle_end) then call cpu_clock_begin(id_clock_diagnostics) - call enable_averaging(CS%time_in_cycle, Time_local, CS%diag) - call post_surface_diagnostics(CS%sfc_IDs, G, GV, CS%diag, CS%time_in_cycle, & - sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) + if (CS%time_in_cycle > 0.0) then + call enable_averaging(CS%time_in_cycle, Time_local, CS%diag) + call post_surface_dyn_diags(CS%sfc_IDs, G, CS%diag, sfc_state, ssh) + endif + if (CS%time_in_thermo_cycle > 0.0) then + call enable_averaging(CS%time_in_thermo_cycle, Time_local, CS%diag) + call post_surface_thermo_diags(CS%sfc_IDs, G, GV, CS%diag, CS%time_in_thermo_cycle, & + sfc_state, CS%tv, ssh, CS%ave_ssh_ibc) + endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) endif @@ -795,7 +843,7 @@ subroutine step_MOM(forces, fluxes, sfc_state, Time_start, time_interval, CS, & end subroutine step_MOM subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & - bbl_time_int, CS, Time_local, rel_time, dyn_call) + bbl_time_int, CS, Time_local, Waves) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the surface !! pressure at the beginning of this dynamic @@ -810,23 +858,23 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & !! bottom boundary layer properties will apply, !! in s, or zero not to update the properties. type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM - type(time_type), intent(in) :: Time_local !< Starting time of a segment, as a time type - real, intent(in) :: rel_time !< Relative time since the start of the current - !! time-stepping cycle, in s. - integer, intent(in) :: dyn_call !< A count of the calls to step_MOM_dynamics - !! within this forcing timestep. + type(time_type), intent(in) :: Time_local !< End time of a segment, as a time type + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave related parameters; the + !! fields in Waves are intent in here. + ! local - type(ocean_grid_type), pointer :: G ! pointer to a structure containing - ! metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing + ! metrics and related information + type(verticalGrid_type), pointer :: GV => NULL() type(MOM_diag_IDs), pointer :: IDs => NULL() ! A structure with the diagnostic IDs. - real, pointer, dimension(:,:,:) :: & - u, & ! u : zonal velocity component (m/s) - v, & ! v : meridional velocity component (m/s) - h ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) + real, dimension(:,:,:), pointer :: & + u => NULL(), & ! u : zonal velocity component (m/s) + v => NULL(), & ! v : meridional velocity component (m/s) + h => NULL() ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) - logical :: calc_dtbt ! Indicates whether the dynamically adjusted - ! barotropic time step needs to be updated. + logical :: calc_dtbt ! Indicates whether the dynamically adjusted + ! barotropic time step needs to be updated. logical :: showCallTree integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -844,7 +892,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if ((CS%t_dyn_rel_adv == 0.0) .and. CS%thickness_diffuse .and. CS%thickness_diffuse_first) then - call enable_averaging(dt_thermo,Time_local+set_time(int(floor(dt_thermo-dt+0.5))), CS%diag) + call enable_averaging(dt_thermo, Time_local+set_time(int(floor(dt_thermo-dt+0.5))), CS%diag) call cpu_clock_begin(id_clock_thick_diff) if (associated(CS%VarMix)) & call calc_slope_functions(h, CS%tv, dt, G, GV, CS%VarMix) @@ -863,7 +911,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! The bottom boundary layer properties need to be recalculated. if (bbl_time_int > 0.0) then call enable_averaging(bbl_time_int, & - Time_local+set_time(int(bbl_time_int-dt+0.5)), CS%diag) + Time_local + set_time(int(bbl_time_int-dt+0.5)), CS%diag) ! Calculate the BBL properties and store them inside visc (u,h). call cpu_clock_begin(id_clock_BBL_visc) call set_viscous_BBL(CS%u, CS%v, CS%h, CS%tv, CS%visc, G, GV, & @@ -878,11 +926,12 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! basically the stacked shallow water equations with viscosity. calc_dtbt = .false. - if ((CS%dtbt_reset_period >= 0.0) .and. & - ((dyn_call==1) .or. (CS%dtbt_reset_period == 0.0) .or. & - (rel_time >= CS%dtbt_reset_time + 0.999*CS%dtbt_reset_period))) then - calc_dtbt = .true. - CS%dtbt_reset_time = rel_time + if (CS%dtbt_reset_period == 0.0) calc_dtbt = .true. + if (CS%dtbt_reset_period > 0.0) then + if (Time_local >= CS%dtbt_reset_time) then !### Change >= to > here. + calc_dtbt = .true. + CS%dtbt_reset_time = CS%dtbt_reset_time + CS%dtbt_reset_interval + endif endif call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & @@ -905,13 +954,12 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & else call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE) + CS%eta_av_bc, G, GV, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, Waves=Waves) endif if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_unsplit (step_MOM)") endif ! -------------------------------------------------- end SPLIT - if (CS%thickness_diffuse .and. .not.CS%thickness_diffuse_first) then call cpu_clock_begin(id_clock_thick_diff) @@ -1044,7 +1092,8 @@ end subroutine step_MOM_tracer_dyn !> MOM_step_thermo orchestrates the thermodynamic time stepping and vertical !! remapping, via calls to diabatic (or adiabatic) and ALE_main. -subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_thermo, update_BBL) +subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, & + Time_end_thermo, update_BBL, Waves) type(MOM_control_struct), intent(inout) :: CS !< Master MOM control structure type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(inout) :: GV !< ocean vertical grid structure @@ -1059,6 +1108,9 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm real, intent(in) :: dtdia !< The time interval over which to advance, in s type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave related parameters + !! the fields in Waves are intent in here. logical :: use_ice_shelf ! Needed for selecting the right ALE interface. logical :: showCallTree @@ -1076,6 +1128,8 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm call enable_averaging(dtdia, Time_end_thermo, CS%diag) + call apply_oda_tracer_increments(dtdia,G,tv,h,CS%odaCS) + if (update_BBL) then ! Calculate the BBL properties and store them inside visc (u,h). ! This is here so that CS%visc is updated before diabatic() when @@ -1101,8 +1155,14 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, Time_end_therm endif call cpu_clock_begin(id_clock_diabatic) - call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & - dtdia, Time_end_thermo, G, GV, CS%diabatic_CSp) + if (CS%use_legacy_diabatic_driver) then + ! the following subroutine is legacy and will be deleted in the near future. + call legacy_diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & + dtdia, Time_end_thermo, G, GV, CS%diabatic_CSp, Waves=Waves) + else + call diabatic(u, v, h, tv, CS%Hml, fluxes, CS%visc, CS%ADp, CS%CDp, & + dtdia, Time_end_thermo, G, GV, CS%diabatic_CSp, Waves=Waves) + endif fluxes%fluxes_used = .true. call cpu_clock_end(id_clock_diabatic) @@ -1214,12 +1274,12 @@ end subroutine step_MOM_thermo !! the work is very preliminary. Some more detail about this capability along with some of the subroutines !! called here can be found in tracers/MOM_offline_control.F90 subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS) - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields - type(surface), intent(inout) :: sfc_state !< surface ocean state - type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< time interval - type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + type(forcing), intent(inout) :: fluxes !< pointers to forcing fields + type(surface), intent(inout) :: sfc_state !< surface ocean state + type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type + real, intent(in) :: time_interval !< time interval + type(MOM_control_struct), pointer :: CS !< control structure from initialize_MOM ! Local pointers type(ocean_grid_type), pointer :: G => NULL() ! Pointer to a structure containing @@ -1236,15 +1296,15 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS logical :: skip_diffusion integer :: id_eta_diff_end - integer, pointer :: accumulated_time + integer, pointer :: accumulated_time => NULL() integer :: i,j,k integer :: is, ie, js, je, isd, ied, jsd, jed ! 3D pointers - real, dimension(:,:,:), pointer :: & - uhtr, vhtr, & - eatr, ebtr, & - h_end + real, dimension(:,:,:), pointer :: & + uhtr => NULL(), vhtr => NULL(), & + eatr => NULL(), ebtr => NULL(), & + h_end => NULL() ! 2D Array for diagnostics real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: eta_pre, eta_end @@ -1264,7 +1324,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call enable_averaging(time_interval, Time_end, CS%diag) ! Check to see if this is the first iteration of the offline interval - if(accumulated_time==0) then + if (accumulated_time==0) then first_iter = .true. else ! This is probably unnecessary but is used to guard against unwanted behavior first_iter = .false. @@ -1279,17 +1339,17 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Increment the amount of time elapsed since last read and check if it's time to roll around accumulated_time = mod(accumulated_time + int(time_interval), dt_offline) - if(accumulated_time==0) then + if (accumulated_time==0) then last_iter = .true. else last_iter = .false. endif - if(CS%use_ALE_algorithm) then + if (CS%use_ALE_algorithm) then ! If this is the first iteration in the offline timestep, then we need to read in fields and ! perform the main advection. if (first_iter) then - if(is_root_pe()) print *, "Reading in new offline fields" + if (is_root_pe()) print *, "Reading in new offline fields" ! Read in new transport and other fields ! call update_transport_from_files(G, GV, CS%offline_CSp, h_end, eatr, ebtr, uhtr, vhtr, & ! CS%tv%T, CS%tv%S, fluxes, CS%use_ALE_algorithm) @@ -1309,7 +1369,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Perform offline diffusion if requested if (.not. skip_diffusion) then if (associated(CS%VarMix)) then - call pass_var(CS%h,G%Domain) + call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, CS%VarMix) endif @@ -1324,7 +1384,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif ! Last thing that needs to be done is the final ALE remapping - if(last_iter) then + if (last_iter) then if (CS%diabatic_first) then call offline_advection_ale(fluxes, Time_start, time_interval, CS%offline_CSp, id_clock_ALE, & CS%h, uhtr, vhtr, converged=adv_converged) @@ -1334,7 +1394,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Perform offline diffusion if requested if (.not. skip_diffusion) then if (associated(CS%VarMix)) then - call pass_var(CS%h,G%Domain) + call pass_var(CS%h, G%Domain) call calc_resoln_function(CS%h, CS%tv, G, GV, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, REAL(dt_offline), G, GV, CS%VarMix) endif @@ -1343,7 +1403,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif endif - if(is_root_pe()) print *, "Last iteration of offline interval" + if (is_root_pe()) print *, "Last iteration of offline interval" ! Apply freshwater fluxes out of the ocean call offline_fw_fluxes_out_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) @@ -1364,7 +1424,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Note that for the layer mode case, the calls to tracer sources and sinks is embedded in ! main_offline_advection_layer. Warning: this may not be appropriate for tracers that ! exchange with the atmosphere - if(time_interval .NE. dt_offline) then + if (time_interval /= dt_offline) then call MOM_error(FATAL, & "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") endif @@ -1390,9 +1450,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call extract_surface_state(CS, sfc_state) call disable_averaging(CS%diag) - call pass_var(CS%tv%T,G%Domain) - call pass_var(CS%tv%S,G%Domain) - call pass_var(CS%h,G%Domain) + call pass_var(CS%tv%T, G%Domain) + call pass_var(CS%tv%S, G%Domain) + call pass_var(CS%h, G%Domain) fluxes%fluxes_used = .true. @@ -1429,7 +1489,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(hor_index_type) :: HI ! A hor_index_type for array extents type(verticalGrid_type), pointer :: GV => NULL() type(dyn_horgrid_type), pointer :: dG => NULL() - type(diag_ctrl), pointer :: diag + type(diag_ctrl), pointer :: diag => NULL() character(len=4), parameter :: vers_num = 'v2.0' @@ -1445,7 +1505,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & real, allocatable, dimension(:,:) :: eta ! free surface height (m) or bottom press (Pa) real, allocatable, dimension(:,:) :: area_shelf_h ! area occupied by ice shelf real, dimension(:,:), allocatable, target :: frac_shelf_h ! fraction of total area occupied by ice shelf - real, dimension(:,:), pointer :: shelf_area + 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 ! GMM, the following *is not* used. Should we delete it? @@ -1453,6 +1513,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & 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 logical :: use_geothermal ! If true, apply geothermal heating. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. @@ -1479,6 +1540,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! of having the data domain on each processor start at 1. logical :: bathy_at_vel ! If true, also define bathymetric fields at the ! the velocity points. + logical :: calc_dtbt ! Indicates whether the dynamically adjusted barotropic + ! time step needs to be updated before it is used. logical :: debug_truncations ! If true, turn on diagnostics useful for debugging truncations. integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the @@ -1528,10 +1591,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "Integer controlling level of messaging\n" // & "\t0 = Only FATAL messages\n" // & "\t2 = Only FATAL, WARNING, NOTE [default]\n" // & - "\t9 = All)", default=2) + "\t9 = All)", default=2, debuggingParam=.true.) call get_param(param_file, "MOM", "DO_UNIT_TESTS", do_unit_tests, & "If True, exercises unit tests at model start up.", & - default=.false.) + default=.false., debuggingParam=.true.) if (do_unit_tests) then call unit_tests(verbosity) endif @@ -1574,6 +1637,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "true. This assumes that KD = KDML = 0.0 and that \n"//& "there is no buoyancy forcing, but makes the model \n"//& "faster by eliminating subroutine calls.", default=.false.) + call get_param(param_file, "MOM", "USE_LEGACY_DIABATIC_DRIVER", CS%use_legacy_diabatic_driver, & + "If true, use the a legacy version of the diabatic subroutine. \n"//& + "This is temporary and is needed avoid change in answers.", & + default=.true.) call get_param(param_file, "MOM", "DO_DYNAMICS", CS%do_dynamics, & "If False, skips the dynamics calls that update u & v, as well as \n"//& "the gravity wave adjustment to h. This is a fragile feature and \n"//& @@ -1625,12 +1692,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "at velocity points. Otherwise the effects of topography \n"//& "are entirely determined from thickness points.", & default=.false.) + call get_param(param_file, "MOM", "USE_WAVES", CS%UseWaves, default=.false., & + do_not_log=.true.) call get_param(param_file, "MOM", "DEBUG", CS%debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, "MOM", "DEBUG_TRUNCATIONS", debug_truncations, & "If true, calculate all diagnostics that are useful for \n"//& - "debugging truncations.", default=.false.) + "debugging truncations.", default=.false., debuggingParam=.true.) call get_param(param_file, "MOM", "DT", CS%dt, & "The (baroclinic) dynamics time step. The time-step that \n"//& @@ -1679,14 +1749,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (CS%split) then call get_param(param_file, "MOM", "DTBT", dtbt, default=-0.98) default_val = CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 - CS%dtbt_reset_period = -1.0 ; CS%dtbt_reset_time = 0.0 + CS%dtbt_reset_period = -1.0 call get_param(param_file, "MOM", "DTBT_RESET_PERIOD", CS%dtbt_reset_period, & "The period between recalculations of DTBT (if DTBT <= 0). \n"//& "If DTBT_RESET_PERIOD is negative, DTBT is set based \n"//& - "only on information available at initialization. If \n"//& - "dynamic, DTBT will be set at least every forcing time \n"//& - "step, and if 0, every dynamics time step. The default is \n"//& - "set by DT_THERM. This is only used if SPLIT is true.", & + "only on information available at initialization. If 0, \n"//& + "DTBT will be set every dynamics time step. The default \n"//& + "is set by DT_THERM. This is only used if SPLIT is true.", & units="s", default=default_val, do_not_read=(dtbt > 0.0)) endif @@ -1742,11 +1811,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "updates, with even numbers (or 0) used for x- first \n"//& "and odd numbers used for y-first.", default=0) - call get_param(param_file, "MOM", "CHECK_BAD_SURFACE_VALS", & - CS%check_bad_surface_vals, & + call get_param(param_file, "MOM", "CHECK_BAD_SURFACE_VALS", CS%check_bad_sfc_vals, & "If true, check the surface state for ridiculous values.", & default=.false.) - if (CS%check_bad_surface_vals) then + if (CS%check_bad_sfc_vals) then call get_param(param_file, "MOM", "BAD_VAL_SSH_MAX", CS%bad_val_ssh_max, & "The value of SSH above which a bad value message is \n"//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & @@ -1763,10 +1831,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "The value of SST below which a bad value message is \n"//& "triggered, if CHECK_BAD_SURFACE_VALS is true.", & units="deg C", default=-2.1) - call get_param(param_file, "MOM", "BAD_VAL_COLUMN_THICKNESS", CS%bad_val_column_thickness, & - "The value of column thickness below which a bad value message is \n"//& - "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & - default=0.0) + call get_param(param_file, "MOM", "BAD_VAL_COLUMN_THICKNESS", CS%bad_vol_col_thick, & + "The value of column thickness below which a bad value message is \n"//& + "triggered, if CHECK_BAD_SURFACE_VALS is true.", units="m", & + default=0.0) endif call get_param(param_file, "MOM", "SAVE_INITIAL_CONDS", save_IC, & @@ -1816,6 +1884,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif + CS%ensemble_ocean=.false. + call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & + "If False, The model is being run in serial mode as a single realization.\n"//& + "If True, The current model realization is part of a larger ensemble \n"//& + "and at the end of step MOM, we will perform a gather of the ensemble\n"//& + "members for statistical evaluation and/or data assimilation.", default=.false.) + call callTree_waypoint("MOM parameters read (initialize_MOM)") ! Set up the model domain and grids. @@ -1918,7 +1993,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & convergence_scale=0.001*GV%H_to_kg_m2, CMOR_tendprefix="osalt", diag_form=2) endif if (associated(CS%OBC)) & - call register_temp_salt_segments(GV, CS%OBC, CS%tv, vd_T, vd_S, param_file) + call register_temp_salt_segments(GV, CS%OBC, CS%tracer_Reg, param_file) endif if (use_frazil) then allocate(CS%tv%frazil(isd:ied,jsd:jed)) ; CS%tv%frazil(:,:) = 0.0 @@ -1971,7 +2046,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ALLOC_(CS%ssh_rint(isd:ied,jsd:jed)) ; CS%ssh_rint(:,:) = 0.0 ALLOC_(CS%ave_ssh_ibc(isd:ied,jsd:jed)) ; CS%ave_ssh_ibc(:,:) = 0.0 ALLOC_(CS%eta_av_bc(isd:ied,jsd:jed)) ; CS%eta_av_bc(:,:) = 0.0 - CS%time_in_cycle = 0.0 + CS%time_in_cycle = 0.0 ; CS%time_in_thermo_cycle = 0.0 ! Use the Wright equation of state by default, unless otherwise specified ! Note: this line and the following block ought to be in a separate @@ -2188,7 +2263,19 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & G, GV, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & - CS%visc, dirs, CS%ntrunc) + CS%visc, dirs, CS%ntrunc, calc_dtbt=calc_dtbt) + if (CS%dtbt_reset_period > 0.0) then + CS%dtbt_reset_interval = set_time(int(floor(CS%dtbt_reset_period))) + ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. + CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & + ((Time - Time_init) / CS%dtbt_reset_interval) + if ((CS%dtbt_reset_time > Time) .and. calc_dtbt) then + ! Back up dtbt_reset_time one interval to force dtbt to be calculated, + ! because the restart was not aligned with the interval to recalculate + ! dtbt, and dtbt was not read from a restart file. + CS%dtbt_reset_time = CS%dtbt_reset_time - CS%dtbt_reset_interval + endif + endif elseif (CS%use_RK2) then call initialize_dyn_unsplit_RK2(CS%u, CS%v, CS%h, Time, G, GV, & param_file, diag, CS%dyn_unsplit_RK2_CSp, restart_CSp, & @@ -2245,7 +2332,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call lock_tracer_registry(CS%tracer_Reg) call callTree_waypoint("tracer registry now locked (initialize_MOM)") - ! now register some diagnostics since the tracer registry is now locked call register_surface_diags(Time, G, CS%sfc_IDs, CS%diag, CS%tv) call register_diags(Time, G, GV, CS%IDs, CS%diag) @@ -2292,6 +2378,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (associated(CS%visc%Kv_shear)) & call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + if (associated(CS%visc%Kv_slow)) & + call pass_var(CS%visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) + call cpu_clock_end(id_clock_pass_init) call register_obsolete_diagnostics(param_file, CS%diag) @@ -2327,17 +2416,21 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1)) + + if (CS%ensemble_ocean) then + call init_oda(Time, G, GV, CS%odaCS) + endif + call callTree_leave("initialize_MOM()") call cpu_clock_end(id_clock_init) end subroutine initialize_MOM !> This subroutine finishes initializing MOM and writes out the initial conditions. -subroutine finish_MOM_initialization(Time, dirs, CS, fluxes, restart_CSp) +subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) type(time_type), intent(in) :: Time !< model time, used in this routine type(directories), intent(in) :: dirs !< structure with directory paths type(MOM_control_struct), pointer :: CS !< pointer to MOM control structure - type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control !! structure that will be used for MOM. ! Local variables @@ -2516,8 +2609,8 @@ subroutine adjust_ssh_for_p_atm(tv, G, GV, ssh, p_atm, use_EOS) integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (present(p_atm)) then ; if (ASSOCIATED(p_atm)) then - calc_rho = ASSOCIATED(tv%eqn_of_state) + if (present(p_atm)) then ; if (associated(p_atm)) then + calc_rho = associated(tv%eqn_of_state) if (present(use_EOS) .and. calc_rho) calc_rho = use_EOS ! Correct the output sea surface height for the contribution from the ! atmospheric pressure @@ -2541,18 +2634,18 @@ end subroutine adjust_ssh_for_p_atm subroutine extract_surface_state(CS, sfc_state) type(MOM_control_struct), pointer :: CS !< Master MOM control structure type(surface), intent(inout) :: sfc_state !< transparent ocean surface state - !! structure shared with the calling routine; + !! structure shared with the calling routine !! data in this structure is intent out. ! local real :: hu, hv type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing ! metrics and related information - type(verticalGrid_type), pointer :: GV => NULL() - real, pointer, dimension(:,:,:) :: & - u, & ! u : zonal velocity component (m/s) - v, & ! v : meridional velocity component (m/s) - h ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) + type(verticalGrid_type), pointer :: GV => NULL() + real, dimension(:,:,:), pointer :: & + u => NULL(), & ! u : zonal velocity component (m/s) + v => NULL(), & ! v : meridional velocity component (m/s) + h => NULL() ! h : layer thickness (meter (Bouss) or kg/m2 (non-Bouss)) real :: depth(SZI_(CS%G)) ! distance from the surface (meter) real :: depth_ml ! depth over which to average to ! determine mixed layer properties (meter) @@ -2774,14 +2867,14 @@ subroutine extract_surface_state(CS, sfc_state) call call_tracer_surface_state(sfc_state, h, G, CS%tracer_flow_CSp) endif - if (CS%check_bad_surface_vals) then + if (CS%check_bad_sfc_vals) then numberOfErrors=0 ! count number of errors do j=js,je; do i=is,ie if (G%mask2dT(i,j)>0.) then localError = sfc_state%sea_lev(i,j)<=-G%bathyT(i,j) & .or. sfc_state%sea_lev(i,j)>= CS%bad_val_ssh_max & .or. sfc_state%sea_lev(i,j)<=-CS%bad_val_ssh_max & - .or. sfc_state%sea_lev(i,j)+G%bathyT(i,j) < CS%bad_val_column_thickness + .or. sfc_state%sea_lev(i,j)+G%bathyT(i,j) < CS%bad_vol_col_thick if (use_temperature) localError = localError & .or. sfc_state%SSS(i,j)<0. & .or. sfc_state%SSS(i,j)>=CS%bad_val_sss_max & @@ -2812,7 +2905,7 @@ subroutine extract_surface_state(CS, sfc_state) endif ! numberOfErrors endif ! localError endif ! mask2dT - enddo; enddo + 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, & @@ -2901,8 +2994,7 @@ subroutine MOM_end(CS) call tracer_registry_end(CS%tracer_Reg) call tracer_flow_control_end(CS%tracer_flow_CSp) - ! GMM, the following is commented because it fails on Travis. - !if (associated(CS%diabatic_CSp)) call diabatic_driver_end(CS%diabatic_CSp) + call diabatic_driver_end(CS%diabatic_CSp) if (CS%offline_tracer_mode) call offline_transport_end(CS%offline_CSp) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index c32352acb1..51a1f1f04e 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -290,6 +290,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) if (OBC%freeslip_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB dudy(I,J) = 0. enddo ; endif + if (OBC%computed_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%dxCu(I,j) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + dudy(I,J) = 2.0*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dxCu(I,j+1) + endif + enddo ; endif + if (OBC%specified_vorticity) then ; do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j)*G%dyBu(I,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + dudy(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dxCu(I,j+1)*G%dyBu(I,J) + endif + enddo ; endif ! Project thicknesses across OBC points with a no-gradient condition. do i = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+2,OBC%segment(n)%HI%ied) @@ -316,6 +330,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) if (OBC%freeslip_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB dvdx(I,J) = 0. enddo ; endif + if (OBC%computed_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = 2.0*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%dyCv(i,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + dvdx(I,J) = 2.0*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%dyCv(i+1,J) + endif + enddo ; endif + if (OBC%specified_vorticity) then ; do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i,J)*G%dxBu(I,J) + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + dvdx(I,J) = OBC%segment(n)%tangential_grad(I,J,k)*G%dyCv(i+1,J)*G%dxBu(I,J) + endif + enddo ; endif ! Project thicknesses across OBC points with a no-gradient condition. do j = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+2,OBC%segment(n)%HI%jed) @@ -411,7 +439,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) if (CS%id_rv > 0) RV(I,J,k) = relative_vorticity if (CS%id_PV > 0) PV(I,J,k) = q(I,J) - if (ASSOCIATED(AD%rv_x_v) .or. ASSOCIATED(AD%rv_x_u)) & + if (associated(AD%rv_x_v) .or. associated(AD%rv_x_u)) & q2(I,J) = relative_vorticity * Ih enddo ; enddo @@ -521,7 +549,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) vhm = 10.0*vhc elseif (abs(vhc) > c1*abs(vhm)) then if (abs(vhc) < c2*abs(vhm)) then ; vhc = (3.0*vhc+(1.0-c2*3.0)*vhm) - else if (abs(vhc) <= c3*abs(vhm)) then ; vhc = vhm + elseif (abs(vhc) <= c3*abs(vhm)) then ; vhc = vhm else ; vhc = slope*vhc+(1.0-c3*slope)*vhm endif endif @@ -642,7 +670,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) ! Term - d(KE)/dx. do j=js,je ; do I=Isq,Ieq CAu(I,j,k) = CAu(I,j,k) - KEx(I,j) - if (ASSOCIATED(AD%gradKEu)) AD%gradKEu(I,j,k) = -KEx(I,j) + if (associated(AD%gradKEu)) AD%gradKEu(I,j,k) = -KEx(I,j) enddo ; enddo @@ -748,13 +776,13 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) ! Term - d(KE)/dy. do J=Jsq,Jeq ; do i=is,ie CAv(i,J,k) = CAv(i,J,k) - KEy(i,J) - if (ASSOCIATED(AD%gradKEv)) AD%gradKEv(i,J,k) = -KEy(i,J) + if (associated(AD%gradKEv)) AD%gradKEv(i,J,k) = -KEy(i,J) enddo ; enddo - if (ASSOCIATED(AD%rv_x_u) .or. ASSOCIATED(AD%rv_x_v)) then + if (associated(AD%rv_x_u) .or. associated(AD%rv_x_v)) then ! Calculate the Coriolis-like acceleration due to relative vorticity. if (CS%Coriolis_Scheme == SADOURNY75_ENERGY) then - if (ASSOCIATED(AD%rv_x_u)) then + if (associated(AD%rv_x_u)) then do J=Jsq,Jeq ; do i=is,ie AD%rv_x_u(i,J,k) = - 0.25* & (q2(I-1,j)*(uh(I-1,j,k) + uh(I-1,j+1,k)) + & @@ -762,7 +790,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) enddo ; enddo endif - if (ASSOCIATED(AD%rv_x_v)) then + if (associated(AD%rv_x_v)) then do j=js,je ; do I=Isq,Ieq AD%rv_x_v(I,j,k) = 0.25 * & (q2(I,j) * (vh(i+1,J,k) + vh(i,J,k)) + & @@ -770,7 +798,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) enddo ; enddo endif else - if (ASSOCIATED(AD%rv_x_u)) then + if (associated(AD%rv_x_u)) then do J=Jsq,Jeq ; do i=is,ie AD%rv_x_u(i,J,k) = -G%IdyCv(i,J) * C1_12 * & ((q2(I,J) + q2(I-1,J) + q2(I-1,J-1)) * uh(I-1,j,k) + & @@ -780,7 +808,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, CS) enddo ; enddo endif - if (ASSOCIATED(AD%rv_x_v)) then + if (associated(AD%rv_x_v)) then do j=js,je ; do I=Isq,Ieq AD%rv_x_v(I,j,k) = G%IdxCu(I,j) * C1_12 * & ((q2(I+1,J) + q2(I,J) + q2(I,J-1)) * vh(i+1,J,k) + & @@ -832,7 +860,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) ! Calculate KE (Kinetic energy for use in the -grad(KE) acceleration term). - if (CS%KE_Scheme.eq.KE_ARAKAWA) then + if (CS%KE_Scheme == KE_ARAKAWA) then ! The following calculation of Kinetic energy includes the metric terms ! identified in Arakawa & Lamb 1982 as important for KE conservation. It ! also includes the possibility of partially-blocked tracer cell faces. @@ -843,7 +871,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) +G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k)) ) & )*0.25*G%IareaT(i,j) enddo ; enddo - elseif (CS%KE_Scheme.eq.KE_SIMPLE_GUDONOV) then + elseif (CS%KE_Scheme == KE_SIMPLE_GUDONOV) then ! The following discretization of KE is based on the one-dimensinal Gudonov ! scheme which does not take into account any geometric factors do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -853,7 +881,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2 = vm*vm KE(i,j) = ( max(up2,um2) + max(vp2,vm2) ) *0.5 enddo ; enddo - elseif (CS%KE_Scheme.eq.KE_GUDONOV) then + elseif (CS%KE_Scheme == KE_GUDONOV) then ! The following discretization of KE is based on the one-dimensinal Gudonov ! scheme but has been adapted to take horizontal grid factors into account do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 32ccdba726..62bd140255 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -8,9 +8,14 @@ module MOM_PressureForce use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_PressureForce_AFV, only : PressureForce_AFV_Bouss, PressureForce_AFV_nonBouss -use MOM_PressureForce_AFV, only : PressureForce_AFV_init, PressureForce_AFV_CS +use MOM_PressureForce_AFV, only : PressureForce_AFV_init, PressureForce_AFV_end +use MOM_PressureForce_AFV, only : PressureForce_AFV_CS +use MOM_PressureForce_blk_AFV, only : PressureForce_blk_AFV_Bouss, PressureForce_blk_AFV_nonBouss +use MOM_PressureForce_blk_AFV, only : PressureForce_blk_AFV_init, PressureForce_blk_AFV_end +use MOM_PressureForce_blk_AFV, only : PressureForce_blk_AFV_CS use MOM_PressureForce_Mont, only : PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss -use MOM_PressureForce_Mont, only : PressureForce_Mont_init, PressureForce_Mont_CS +use MOM_PressureForce_Mont, only : PressureForce_Mont_init, PressureForce_Mont_end +use MOM_PressureForce_Mont, only : PressureForce_Mont_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -25,8 +30,12 @@ module MOM_PressureForce type, public :: PressureForce_CS ; private logical :: Analytic_FV_PGF !< If true, use the analytic finite volume form !! (Adcroft et al., Ocean Mod. 2008) of the PGF. + logical :: blocked_AFV !< If true, used the blocked version of the ANALYTIC_FV_PGF + !! code. The value of this parameter should not change answers. !> Control structure for the analytically integrated finite volume pressure force type(PressureForce_AFV_CS), pointer :: PressureForce_AFV_CSp => NULL() + !> Control structure for the analytically integrated finite volume pressure force + type(PressureForce_blk_AFV_CS), pointer :: PressureForce_blk_AFV_CSp => NULL() !> Control structure for the Montgomery potential form of pressure force type(PressureForce_Mont_CS), pointer :: PressureForce_Mont_CSp => NULL() end type PressureForce_CS @@ -35,26 +44,42 @@ module MOM_PressureForce !> A thin layer between the model and the Boussinesq and non-Boussinesq pressure force routines. subroutine PressureForce(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv - type(PressureForce_CS), pointer :: CS - type(ALE_CS), pointer :: ALE_CSp - real, dimension(:,:), optional, pointer :: p_atm - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta - - - if (CS%Analytic_FV_PGF) then + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: PFu !< Zonal pressure force acceleration (m/s2) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: PFv !< Meridional pressure force acceleration (m/s2) + type(PressureForce_CS), pointer :: CS !< Pressure force control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + real, dimension(:,:), & + optional, pointer :: p_atm !< The pressure at the ice-ocean or + !! atmosphere-ocean interface in Pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: pbce !< The baroclinic pressure anomaly in each layer + !! due to eta anomalies, in m2 s-2 H-1. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(out) :: eta !< The bottom mass used to calculate PFu and PFv, + !! in H, with any tidal contributions. + + if (CS%Analytic_FV_PGF .and. CS%blocked_AFV) then + if (GV%Boussinesq) then + call PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, & + CS%PressureForce_blk_AFV_CSp, ALE_CSp, p_atm, pbce, eta) + else + call PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, & + CS%PressureForce_blk_AFV_CSp, p_atm, pbce, eta) + endif + elseif (CS%Analytic_FV_PGF) then if (GV%Boussinesq) then call PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS%PressureForce_AFV_CSp, & ALE_CSp, p_atm, pbce, eta) else call PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS%PressureForce_AFV_CSp, & - p_atm, pbce, eta) + ALE_CSp, p_atm, pbce, eta) endif else if (GV%Boussinesq) then @@ -94,8 +119,15 @@ subroutine PressureForce_init(Time, G, GV, param_file, diag, CS, tides_CSp) "the equations of state in pressure to avoid any \n"//& "possibility of numerical thermobaric instability, as \n"//& "described in Adcroft et al., O. Mod. (2008).", default=.true.) - - if (CS%Analytic_FV_PGF) then + call get_param(param_file, mdl, "BLOCKED_ANALYTIC_FV_PGF", CS%blocked_AFV, & + "If true, used the blocked version of the ANALYTIC_FV_PGF \n"//& + "code. The value of this parameter should not change answers.", & + default=.false., do_not_log=.true., debuggingParam=.true.) + + if (CS%Analytic_FV_PGF .and. CS%blocked_AFV) then + call PressureForce_blk_AFV_init(Time, G, GV, param_file, diag, & + CS%PressureForce_blk_AFV_CSp, tides_CSp) + elseif (CS%Analytic_FV_PGF) then call PressureForce_AFV_init(Time, G, GV, param_file, diag, & CS%PressureForce_AFV_CSp, tides_CSp) else @@ -108,6 +140,15 @@ end subroutine PressureForce_init !> Deallocate the pressure force control structure subroutine PressureForce_end(CS) type(PressureForce_CS), pointer :: CS !< Pressure force control structure + + if (CS%Analytic_FV_PGF .and. CS%blocked_AFV) then + call PressureForce_blk_AFV_end(CS%PressureForce_blk_AFV_CSp) + elseif (CS%Analytic_FV_PGF) then + call PressureForce_AFV_end(CS%PressureForce_AFV_CSp) + else + call PressureForce_Mont_end(CS%PressureForce_Mont_CSp) + endif + if (associated(CS)) deallocate(CS) end subroutine PressureForce_end diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index d47692f2bc..a30f8e9974 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -31,12 +31,12 @@ module MOM_PressureForce_Mont real :: GFS_scale !< Ratio between gravity applied to top interface !! and the gravitational acceleration of the planet. !! Usually this ratio is 1. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. - real, pointer :: PFu_bc(:,:,:) => NULL() ! Accelerations due to pressure - real, pointer :: PFv_bc(:,:,:) => NULL() ! gradients deriving from density - ! gradients within layers, m s-2. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. + real, pointer :: PFu_bc(:,:,:) => NULL() !< Accelerations due to pressure + real, pointer :: PFv_bc(:,:,:) => NULL() !< gradients deriving from density + !! gradients within layers, m s-2. integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1 type(tidal_forcing_CS), pointer :: tides_CSp => NULL() end type PressureForce_Mont_CS @@ -63,12 +63,14 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration due to pressure gradients !! (equal to -dM/dy) in m/s2. type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF - real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or + real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean or !! atmosphere-ocean in Pa. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure anomaly in + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: pbce !< The baroclinic pressure anomaly in !! each layer due to free surface height anomalies, !! in m2 s-2 H-1. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height, in m. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< Free surface height, in m. + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & M, & ! The Montgomery potential, M = (p/rho + gz) , in m2 s-2. @@ -328,14 +330,14 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, ((dp_star(i,j) * dp_star(i+1,j) + (p(i,j,K) * dp_star(i+1,j) + & p(i+1,j,K) * dp_star(i,j))) / (dp_star(i,j) + dp_star(i+1,j)))) PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc - if (ASSOCIATED(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc + if (associated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc enddo ; enddo do J=Jsq,Jeq ; do i=is,ie PFv_bc = (alpha_star(i,j+1,k) - alpha_star(i,j,k)) * (G%IdyCv(i,J) * & ((dp_star(i,j) * dp_star(i,j+1) + (p(i,j,K) * dp_star(i,j+1) + & p(i,j+1,K) * dp_star(i,j))) / (dp_star(i,j) + dp_star(i,j+1)))) PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc - if (ASSOCIATED(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc + if (associated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc enddo ; enddo enddo ! k-loop else ! .not. use_EOS @@ -568,14 +570,14 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta ((h_star(i,j) * h_star(i+1,j) - (e(i,j,K) * h_star(i+1,j) + & e(i+1,j,K) * h_star(i,j))) / (h_star(i,j) + h_star(i+1,j)))) PFu(I,j,k) = -(M(i+1,j,k) - M(i,j,k)) * G%IdxCu(I,j) + PFu_bc - if (ASSOCIATED(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc + if (associated(CS%PFu_bc)) CS%PFu_bc(i,j,k) = PFu_bc enddo ; enddo do J=Jsq,Jeq ; do i=is,ie PFv_bc = -1.0*(rho_star(i,j+1,k) - rho_star(i,j,k)) * (G%IdyCv(i,J) * & ((h_star(i,j) * h_star(i,j+1) - (e(i,j,K) * h_star(i,j+1) + & e(i,j+1,K) * h_star(i,j))) / (h_star(i,j) + h_star(i,j+1)))) PFv(i,J,k) = -(M(i,j+1,k) - M(i,j,k)) * G%IdyCv(i,J) + PFv_bc - if (ASSOCIATED(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc + if (associated(CS%PFv_bc)) CS%PFv_bc(i,j,k) = PFv_bc enddo ; enddo enddo ! k-loop else ! .not. use_EOS @@ -616,19 +618,21 @@ end subroutine PressureForce_Mont_Bouss !> Determines the partial derivative of the acceleration due !! to pressure forces with the free surface height. subroutine Set_pbce_Bouss(e, tv, G, GV, g_Earth, Rho0, GFS_scale, pbce, rho_star) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface height, in H. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, intent(in) :: g_Earth !< The gravitational acceleration, in m s-2. real, intent(in) :: Rho0 !< The "Boussinesq" ocean density, in kg m-3. real, intent(in) :: GFS_scale !< Ratio between gravity applied to top interface - !! and the gravitational acceleration of the planet. - !! Usually this ratio is 1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: pbce !< The baroclinic pressure anomaly in each layer due - !! to free surface height anomalies, in m2 H-1 s-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(in) :: rho_star !< The layer densities (maybe - !! compressibility compensated), times g/rho_0, in m s-2. + !! and the gravitational acceleration of the planet. + !! Usually this ratio is 1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(out) :: pbce !< The baroclinic pressure anomaly in each layer due + !! to free surface height anomalies, in m2 H-1 s-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: rho_star !< The layer densities (maybe compressibility + !! compensated), times g/rho_0, in m s-2. ! Local variables real :: Ihtot(SZI_(G)) ! The inverse of the sum of the layer ! thicknesses, in m-1. @@ -902,7 +906,7 @@ end subroutine PressureForce_Mont_init !> Deallocates the Montgomery-potential form of PGF control structure subroutine PressureForce_Mont_end(CS) - type(PressureForce_Mont_CS), pointer :: CS + type(PressureForce_Mont_CS), pointer :: CS !< Control structure for Montgomery potential PGF if (associated(CS)) deallocate(CS) end subroutine PressureForce_Mont_end diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 52e0b6bb93..672651ffb0 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -15,11 +15,9 @@ module MOM_PressureForce_AFV use MOM_EOS, only : calculate_density, calculate_density_derivs use MOM_EOS, only : int_density_dz, int_specific_vol_dp use MOM_EOS, only : int_density_dz_generic_plm, int_density_dz_generic_ppm -use MOM_EOS, only : int_density_dz_generic_plm_analytic -use MOM_ALE, only : pressure_gradient_plm, pressure_gradient_ppm -use MOM_ALE, only : usePressureReconstruction, pressureReconstructionScheme -use MOM_ALE, only : ALE_CS -use regrid_defs, only: PRESSURE_RECONSTRUCTION_PLM, PRESSURE_RECONSTRUCTION_PPM +use MOM_EOS, only : int_spec_vol_dp_generic_plm +use MOM_EOS, only : int_density_dz_generic, int_spec_vol_dp_generic +use MOM_ALE, only : pressure_gradient_plm, pressure_gradient_ppm, ALE_CS implicit none ; private @@ -39,6 +37,18 @@ module MOM_PressureForce_AFV type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. logical :: useMassWghtInterp !< Use mass weighting in T/S interpolation + logical :: boundary_extrap !< Indicate whether high-order boundary + !! extrapolation should be used within boundary cells + + logical :: reconstruct !< If true, polynomial profiles of T & S will be + !! reconstructed and used in the integrals for the + !! finite volume pressure gradient calculation. + !! The default depends on whether regridding is being used. + + integer :: Recon_Scheme !< Order of the polynomial of the reconstruction of T & S + !! for the finite volume pressure gradient calculation. + !! By the default (1) is for a piecewise linear method + integer :: id_e_tidal = -1 !< Diagnostic identifier type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_AFV_CS @@ -68,7 +78,7 @@ subroutine PressureForce_AFV(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, e if (GV%Boussinesq) then call PressureForce_AFV_bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) else - call PressureForce_AFV_nonbouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta) + call PressureForce_AFV_nonbouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) endif end subroutine PressureForce_AFV @@ -83,14 +93,15 @@ end subroutine PressureForce_AFV !! ie to ie, je to je range before this subroutine is called: !! h[ie+1] and h[je+1] and (if tv%eqn_of_state is set) T[ie+1], S[ie+1], !! T[je+1], and S[je+1]. -subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (kg/m2) - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) - type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure +subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (kg/m2) + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + type(PressureForce_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean !! or atmosphere-ocean interface in Pa. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure @@ -106,6 +117,9 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e ! than the mixed layer have the mixed layer's properties, in C. S_tmp ! Temporary array of salinities where layers that are lighter ! than the mixed layer have the mixed layer's properties, in psu. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + S_t, S_b, T_t, T_b ! Top and bottom edge values for linear reconstructions + ! of salinity and temperature within each layer. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & dza, & ! The change in geopotential anomaly between the top and bottom ! of a layer, in m2 s-2. @@ -120,21 +134,17 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e ! account for a reduced gravity model, in m2 s-2. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the ! interface atop a layer, in m2 s-2. - real, dimension(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - dp_bk, & ! The (positive) change in pressure across a layer, in Pa. - za_bk ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer, in m2 s-2. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer, in kg m-3. - real, dimension(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - intx_za_bk ! The zonal integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing, m2 s-2. + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_za ! The zonal integral of the geopotential anomaly along the + ! interface below a layer, divided by the grid spacing, m2 s-2. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & intx_dza ! The change in intx_za through a layer, in m2 s-2. - real, dimension(SZDI_(G%Block(1)),SZDJB_(G%Block(1))) :: & ! on block indices - inty_za_bk ! The meridional integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing, m2 s-2. + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_za ! The meridional integral of the geopotential anomaly along the + ! interface below a layer, divided by the grid spacing, m2 s-2. real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & inty_dza ! The change in inty_za through a layer, in m2 s-2. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate @@ -145,6 +155,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e real :: alpha_anom ! The in-situ specific volume, averaged over a ! layer, less alpha_ref, in m3 kg-1. logical :: use_p_atm ! If true, use the atmospheric pressure. + logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an ! equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. @@ -157,40 +168,39 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e real :: I_gEarth real, parameter :: C1_6 = 1.0/6.0 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: is_bk, ie_bk, js_bk, je_bk, Isq_bk, Ieq_bk, Jsq_bk, Jeq_bk - integer :: i, j, k, n, ib, jb, ioff_bk, joff_bk + integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + if (.not.associated(CS)) call MOM_error(FATAL, & + "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") + use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif use_EOS = associated(tv%eqn_of_state) - - if (.not.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce: Module must be initialized before it is used.") + use_ALE = .false. + if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS dp_neglect = GV%H_to_Pa * GV%H_subroundoff alpha_ref = 1.0/CS%Rho0 -!$OMP parallel default(none) shared(Isq,Ieq,Jsq,Jeq,nz,use_p_atm,p,p_atm,GV,h) if (use_p_atm) then -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 p(i,j,1) = p_atm(i,j) enddo ; enddo else -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 p(i,j,1) = 0.0 ! or oneatm enddo ; enddo endif -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=2,nz+1 ; do i=Isq,Ieq+1 p(i,j,K) = p(i,j,K-1) + GV%H_to_Pa * h(i,j,k-1) enddo ; enddo ; enddo -!$OMP end parallel I_gEarth = 1.0 / GV%g_Earth @@ -203,8 +213,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,nkmb,tv_tmp,tv,p_ref,GV) & -!$OMP private(Rho_cv_BL) + !$OMP parallel do default(shared) private(Rho_cv_BL) do j=Jsq,Jeq+1 do k=1,nkmb ; do i=Isq,Ieq+1 tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -225,17 +234,47 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e endif endif -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,is,ie,js,je,tv_tmp,alpha_ref, & -!$OMP p,h,G,GV,tv,dza,intp_dza,intx_dza,inty_dza,use_EOS) & -!$OMP private(alpha_anom,dp) + ! If regridding is activated, do a linear reconstruction of salinity + ! and temperature across each layer. The subscripts 't' and 'b' refer + ! to top and bottom values within each layer (these are the only degrees + ! of freedeom needed to know the linear profile). + if ( use_ALE ) then + if ( CS%Recon_Scheme == 1 ) then + call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( CS%Recon_Scheme == 2) then + call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + endif + endif + + !$OMP parallel do default(shared) private(alpha_anom,dp) do k=1,nz ! Calculate 4 integrals through the layer that are required in the ! subsequent calculation. if (use_EOS) then - call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & + if ( use_ALE ) then + if ( CS%Recon_Scheme == 1 ) then + call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), & + S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & + alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & + tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), & + intx_dza(:,:,k), inty_dza(:,:,k), & + useMassWghtInterp = CS%useMassWghtInterp) + i=k + elseif ( CS%Recon_Scheme == 2 ) then + call MOM_error(FATAL, "PressureForce_AFV_nonBouss: "//& + "int_spec_vol_dp_generic_ppm does not exist yet.") + ! call int_spec_vol_dp_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & + ! tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & + ! alpha_ref, G%HI, tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), & + ! intx_dza(:,:,k), inty_dza(:,:,k)) + endif + else + call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & - inty_dza(:,:,k)) + inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & + useMassWghtInterp = CS%useMassWghtInterp) + endif else alpha_anom = 1.0/GV%Rlay(k) - alpha_ref do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -260,24 +299,24 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e ! inty_dza to be 3-D arrays. ! Sum vertically to determine the surface geopotential anomaly. -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,za,alpha_ref,p,G,GV,dza) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) enddo do k=nz,1,-1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) + dza(i,j,k) + za(i,j) = za(i,j) + dza(i,j,k) enddo ; enddo enddo if (CS%tides) then ! Find and add the tidal geopotential anomaly. -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,SSH,za,alpha_ref,p,I_gEarth) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth enddo ; enddo call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp) -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,za,G,GV,e_tidal) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 za(i,j) = za(i,j) - GV%g_Earth*e_tidal(i,j) enddo ; enddo @@ -286,8 +325,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e if (CS%GFS_scale < 1.0) then ! Adjust the Montgomery potential to make this a reduced gravity model. if (use_EOS) then -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,tv_tmp,p,tv,dM,CS,alpha_ref,za) & -!$OMP private(rho_in_situ) + !$OMP parallel do default(shared) private(rho_in_situ) do j=Jsq,Jeq+1 call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), & rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) @@ -298,7 +336,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e enddo enddo else -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,dM,CS,p,GV,alpha_ref,za) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * & (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) @@ -313,69 +351,54 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e ! linearly between the values at thickness points, but the bottom ! geopotentials will not now be linear at the sub-grid-scale. Doing this ! ensures no motion with flat isopycnals, even with a nonlinear equation of state. -!$OMP parallel do default(none) shared(nz,za,G,GV,dza,intx_dza,h,PFu, & -!$OMP intp_dza,p,dp_neglect,inty_dza,PFv,CS,dM) & -!$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & -!$OMP Jeq_bk,ioff_bk,joff_bk,i,j,za_bk,intx_za_bk, & -!$OMP inty_za_bk,dp_bk) - do n = 1, G%nblocks - is_bk=G%block(n)%isc ; ie_bk=G%block(n)%iec - js_bk=G%block(n)%jsc ; je_bk=G%block(n)%jec - Isq_bk=G%block(n)%IscB ; Ieq_bk=G%block(n)%IecB - Jsq_bk=G%block(n)%JscB ; Jeq_bk=G%block(n)%JecB - ioff_bk = G%Block(n)%idg_offset - G%HI%idg_offset - joff_bk = G%Block(n)%jdg_offset - G%HI%jdg_offset - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - za_bk(ib,jb) = za(i,j) + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j) = 0.5*(za(i,j) + za(i+1,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J) = 0.5*(za(i,j) + za(i,j+1)) + enddo ; enddo + do k=1,nz + ! These expressions for the acceleration have been carefully checked in + ! a set of idealized cases, and should be bug-free. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dp(i,j) = GV%H_to_Pa*h(i,j,k) + za(i,j) = za(i,j) - dza(i,j,k) enddo ; enddo - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - I = Ib+ioff_bk ; j = jb+joff_bk - intx_za_bk(Ib,jb) = 0.5*(za_bk(ib,jb) + za_bk(ib+1,jb)) + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j) = intx_za(I,j) - intx_dza(I,j,k) + PFu(I,j,k) = (((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i+1,j)*dp(i+1,j) + intp_dza(i+1,j,k))) + & + ((dp(i+1,j) - dp(i,j)) * intx_za(I,j) - & + (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k))) * & + (2.0*G%IdxCu(I,j) / ((dp(i,j) + dp(i+1,j)) + & + dp_neglect)) enddo ; enddo - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - i = ib+ioff_bk ; J = Jb+joff_bk - inty_za_bk(ib,Jb) = 0.5*(za_bk(ib,jb) + za_bk(ib,jb+1)) + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J) = inty_za(i,J) - inty_dza(i,J,k) + PFv(i,J,k) = (((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i,j+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & + ((dp(i,j+1) - dp(i,j)) * inty_za(i,J) - & + (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & + (2.0*G%IdyCv(i,J) / ((dp(i,j) + dp(i,j+1)) + & + dp_neglect)) enddo ; enddo - do k=1,nz - ! These expressions for the acceleration have been carefully checked in - ! a set of idealized cases, and should be bug-free. - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - dp_bk(ib,jb) = GV%H_to_Pa*h(i,j,k) - za_bk(ib,jb) = za_bk(ib,jb) - dza(i,j,k) - enddo ; enddo - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - I = Ib+ioff_bk ; j = jb+joff_bk - intx_za_bk(Ib,jb) = intx_za_bk(Ib,jb) - intx_dza(I,j,k) - PFu(I,j,k) = (((za_bk(ib,jb)*dp_bk(ib,jb) + intp_dza(i,j,k)) - & - (za_bk(ib+1,jb)*dp_bk(ib+1,jb) + intp_dza(i+1,j,k))) + & - ((dp_bk(ib+1,jb) - dp_bk(ib,jb)) * intx_za_bk(Ib,jb) - & - (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k))) * & - (2.0*G%IdxCu(I,j) / ((dp_bk(ib,jb) + dp_bk(ib+1,jb)) + & - dp_neglect)) + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - i = ib+ioff_bk ; J = Jb+joff_bk - inty_za_bk(ib,Jb) = inty_za_bk(ib,Jb) - inty_dza(i,J,k) - PFv(i,J,k) = (((za_bk(ib,jb)*dp_bk(ib,jb) + intp_dza(i,j,k)) - & - (za_bk(ib,jb+1)*dp_bk(ib,jb+1) + intp_dza(i,j+1,k))) + & - ((dp_bk(ib,jb+1) - dp_bk(ib,jb)) * inty_za_bk(ib,Jb) - & - (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & - (2.0*G%IdyCv(i,J) / ((dp_bk(ib,jb) + dp_bk(ib,jb+1)) + & - dp_neglect)) + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo - - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - do j=js_bk+joff_bk,je_bk+joff_bk ; do I=Isq_bk+ioff_bk,Ieq_bk+ioff_bk - PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) - enddo ; enddo - do J=Jsq_bk+joff_bk,Jeq_bk+joff_bk ; do i=is_bk+ioff_bk,ie_bk+ioff_bk - PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) - enddo ; enddo - endif - enddo + endif enddo if (present(pbce)) then @@ -385,12 +408,12 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, e if (present(eta)) then Pa_to_H = 1.0 / GV%H_to_Pa if (use_p_atm) then -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,eta,p,p_atm,Pa_to_H) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta(i,j) = (p(i,j,nz+1) - p_atm(i,j))*Pa_to_H ! eta has the same units as h. enddo ; enddo else -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,eta,p,Pa_to_H) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta(i,j) = p(i,j,nz+1)*Pa_to_H ! eta has the same units as h. enddo ; enddo @@ -437,22 +460,22 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p real, dimension(SZI_(G)) :: & Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer, in kg m-3. - real, dimension(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - dz_bk, & ! The change in geopotential thickness through a layer, m2 s-2. - pa_bk, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the - ! the interface atop a layer, in Pa. - dpa_bk, & ! The change in pressure anomaly between the top and bottom - ! of a layer, in Pa. - intz_dpa_bk ! The vertical integral in depth of the pressure anomaly less - ! the pressure anomaly at the top of the layer, in H Pa (m Pa). - real, dimension(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices - intx_pa_bk, & ! The zonal integral of the pressure anomaly along the interface - ! atop a layer, divided by the grid spacing, in Pa. - intx_dpa_bk ! The change in intx_pa through a layer, in Pa. - real, dimension(SZDI_(G%Block(1)),SZDJB_(G%Block(1))) :: & ! on block indices - inty_pa_bk, & ! The meridional integral of the pressure anomaly along the - ! interface atop a layer, divided by the grid spacing, in Pa. - inty_dpa_bk ! The change in inty_pa through a layer, in Pa. + real, dimension(SZI_(G),SZJ_(G)) :: & + dz, & ! The change in geopotential thickness through a layer, m2 s-2. + pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the + ! the interface atop a layer, in Pa. + dpa, & ! The change in pressure anomaly between the top and bottom + ! of a layer, in Pa. + intz_dpa ! The vertical integral in depth of the pressure anomaly less + ! the pressure anomaly at the top of the layer, in H Pa (m Pa). + real, dimension(SZIB_(G),SZJ_(G)) :: & + intx_pa, & ! The zonal integral of the pressure anomaly along the interface + ! atop a layer, divided by the grid spacing, in Pa. + intx_dpa ! The change in intx_pa through a layer, in Pa. + real, dimension(SZI_(G),SZJB_(G)) :: & + inty_pa, & ! The meridional integral of the pressure anomaly along the + ! interface atop a layer, divided by the grid spacing, in Pa. + inty_dpa ! The change in inty_pa through a layer, in Pa. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & T_tmp, & ! Temporary array of temperatures where layers that are lighter @@ -480,26 +503,22 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p real, parameter :: C1_6 = 1.0/6.0 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb - integer :: is_bk, ie_bk, js_bk, je_bk, Isq_bk, Ieq_bk, Jsq_bk, Jeq_bk - integer :: ioff_bk, joff_bk - integer :: i, j, k, n, ib, jb - integer :: PRScheme + integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke nkmb=GV%nk_rho_varies Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB if (.not.associated(CS)) call MOM_error(FATAL, & - "MOM_PressureForce: Module must be initialized before it is used.") + "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") use_p_atm = .false. if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif use_EOS = associated(tv%eqn_of_state) do i=Isq,Ieq+1 ; p0(i) = 0.0 ; enddo use_ALE = .false. - if (associated(ALE_CSp)) use_ALE = usePressureReconstruction(ALE_CSp) .and. use_EOS + if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS - PRScheme = pressureReconstructionScheme(ALE_CSp) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff * GV%H_to_m I_Rho0 = 1.0/GV%Rho0 @@ -511,7 +530,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p ! and loading. This should really be based on bottom pressure anomalies, ! but that is not yet implemented, and the current form is correct for ! barotropic tides. -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nz,e,G,GV,h) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 e(i,j,1) = -1.0*G%bathyT(i,j) @@ -524,23 +543,21 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p endif ! Here layer interface heights, e, are calculated. -!$OMP parallel default(none) shared(Isq,Ieq,Jsq,Jeq,nz,e,G,GV,h,CS,e_tidal) if (CS%tides) then -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 e(i,j,nz+1) = -1.0*G%bathyT(i,j) - e_tidal(i,j) enddo ; enddo else -!$OM do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 e(i,j,nz+1) = -1.0*G%bathyT(i,j) enddo ; enddo endif -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1; do k=nz,1,-1 ; do i=Isq,Ieq+1 e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_m enddo ; enddo ; enddo -!$OMP end parallel if (use_EOS) then @@ -554,8 +571,7 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo -!$OMP parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,nkmb,nz,GV,tv_tmp,tv,p_ref) & -!$OMP private(Rho_cv_BL) + !$OMP parallel do default(shared) private(Rho_cv_BL) do j=Jsq,Jeq+1 do k=1,nkmb ; do i=Isq,Ieq+1 tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -577,13 +593,10 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p endif endif -!$OMP parallel default(none) shared(Jsq,Jeq,Isq,Ieq,tv_tmp,p_atm,rho_in_situ,tv, & -!$OMP p0,dM,CS,G_Rho0,e,use_p_atm,use_EOS,GV, & -!$OMP rho_ref,js,je,is,ie) if (CS%GFS_scale < 1.0) then ! Adjust the Montgomery potential to make this a reduced gravity model. if (use_EOS) then -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 if (use_p_atm) then call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), & @@ -597,152 +610,143 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p enddo enddo else -!$OMP do + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * e(i,j,1) enddo ; enddo endif endif -!$OMP end parallel - -! Have checked that rho_0 drops out and that the 1-layer case is right. RWH. + ! I have checked that rho_0 drops out and that the 1-layer case is right. RWH. ! If regridding is activated, do a linear reconstruction of salinity ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees ! of freedeom needed to know the linear profile). if ( use_ALE ) then - if ( PRScheme == PRESSURE_RECONSTRUCTION_PLM ) then - call pressure_gradient_plm (ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h); - elseif ( PRScheme == PRESSURE_RECONSTRUCTION_PPM ) then - call pressure_gradient_ppm (ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h); + if ( CS%Recon_Scheme == 1 ) then + call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( CS%Recon_Scheme == 2 ) then + call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif -!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e,p_atm,nz,use_EOS,& -!$OMP use_ALE,PRScheme,T_t,T_b,S_t,S_b,CS,tv,tv_tmp, & -!$OMP h,PFu,I_Rho0,h_neglect,dz_neglect,PFv,dM)& -!$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & -!$OMP Jeq_bk,ioff_bk,joff_bk,pa_bk, & -!$OMP intx_pa_bk,inty_pa_bk,dpa_bk,intz_dpa_bk, & -!$OMP intx_dpa_bk,inty_dpa_bk,dz_bk,i,j) - do n = 1, G%nblocks - is_bk=G%Block(n)%isc ; ie_bk=G%Block(n)%iec - js_bk=G%Block(n)%jsc ; je_bk=G%Block(n)%jec - Isq_bk=G%Block(n)%IscB ; Ieq_bk=G%Block(n)%IecB - Jsq_bk=G%Block(n)%JscB ; Jeq_bk=G%Block(n)%JecB - ioff_bk = G%Block(n)%idg_offset - G%HI%idg_offset - joff_bk = G%Block(n)%jdg_offset - G%HI%jdg_offset - - ! Set the surface boundary conditions on pressure anomaly and its horizontal - ! integrals, assuming that the surface pressure anomaly varies linearly - ! in x and y. - if (use_p_atm) then - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - pa_bk(ib,jb) = (rho_ref*GV%g_Earth)*e(i,j,1) + p_atm(i,j) - enddo ; enddo - else - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - pa_bk(ib,jb) = (rho_ref*GV%g_Earth)*e(i,j,1) - enddo ; enddo - endif - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - intx_pa_bk(Ib,jb) = 0.5*(pa_bk(ib,jb) + pa_bk(ib+1,jb)) + ! Set the surface boundary conditions on pressure anomaly and its horizontal + ! integrals, assuming that the surface pressure anomaly varies linearly + ! in x and y. + if (use_p_atm) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j) = (rho_ref*GV%g_Earth)*e(i,j,1) + p_atm(i,j) enddo ; enddo - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - inty_pa_bk(ib,Jb) = 0.5*(pa_bk(ib,jb) + pa_bk(ib,jb+1)) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j) = (rho_ref*GV%g_Earth)*e(i,j,1) enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j) = 0.5*(pa(i,j) + pa(i+1,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J) = 0.5*(pa(i,j) + pa(i,j+1)) + enddo ; enddo - do k=1,nz - ! Calculate 4 integrals through the layer that are required in the - ! subsequent calculation. - - if (use_EOS) then - ! The following routine computes the integrals that are needed to - ! calculate the pressure gradient force. Linear profiles for T and S are - ! assumed when regridding is activated. Otherwise, the previous version - ! is used, whereby densities within each layer are constant no matter - ! where the layers are located. - if ( use_ALE ) then - if ( PRScheme == PRESSURE_RECONSTRUCTION_PLM ) then - call int_density_dz_generic_plm ( T_t(:,:,k), T_b(:,:,k), & - S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, & - dz_neglect, G%bathyT, G%HI, G%Block(n), & - tv%eqn_of_state, dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & - useMassWghtInterp = CS%useMassWghtInterp) - elseif ( PRScheme == PRESSURE_RECONSTRUCTION_PPM ) then - call int_density_dz_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & - tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, & - G%HI, G%Block(n), tv%eqn_of_state, dpa_bk, intz_dpa_bk, & - intx_dpa_bk, inty_dpa_bk) - endif - else - call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), & - e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, G%Block(n), tv%eqn_of_state, & - dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk ) + do k=1,nz + ! Calculate 4 integrals through the layer that are required in the + ! subsequent calculation. + + if (use_EOS) then + ! The following routine computes the integrals that are needed to + ! calculate the pressure gradient force. Linear profiles for T and S are + ! assumed when regridding is activated. Otherwise, the previous version + ! is used, whereby densities within each layer are constant no matter + ! where the layers are located. + if ( use_ALE ) then + if ( CS%Recon_Scheme == 1 ) then + call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), & + S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, GV%g_Earth, & + dz_neglect, G%bathyT, G%HI, G%HI, & + tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & + useMassWghtInterp = CS%useMassWghtInterp) + elseif ( CS%Recon_Scheme == 2 ) then + call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & + tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, GV%g_Earth, & + G%HI, G%HI, tv%eqn_of_state, dpa, intz_dpa, & + intx_dpa, inty_dpa) endif - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - intz_dpa_bk(ib,jb) = intz_dpa_bk(ib,jb)*GV%m_to_H - enddo ; enddo else - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - i = ib+ioff_bk ; j = jb+joff_bk - dz_bk(ib,jb) = GV%g_Earth*GV%H_to_m*h(i,j,k) - dpa_bk(ib,jb) = (GV%Rlay(k) - rho_ref)*dz_bk(ib,jb) - intz_dpa_bk(ib,jb) = 0.5*(GV%Rlay(k) - rho_ref)*dz_bk(ib,jb)*h(i,j,k) - enddo ; enddo - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - intx_dpa_bk(Ib,jb) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib+1,jb)) - enddo ; enddo - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - inty_dpa_bk(ib,Jb) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib,jb+1)) - enddo ; enddo + call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), & + e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, G%HI, tv%eqn_of_state, & + dpa, intz_dpa, intx_dpa, inty_dpa, & + G%bathyT, dz_neglect, CS%useMassWghtInterp) endif - - ! Compute pressure gradient in x direction - do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk - I = Ib+ioff_bk ; j = jb+joff_bk - PFu(I,j,k) = (((pa_bk(ib,jb)*h(i,j,k) + intz_dpa_bk(ib,jb)) - & - (pa_bk(ib+1,jb)*h(i+1,j,k) + intz_dpa_bk(ib+1,jb))) + & - ((h(i+1,j,k) - h(i,j,k)) * intx_pa_bk(Ib,jb) - & - (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa_bk(Ib,jb) * GV%m_to_H)) * & - ((2.0*I_Rho0*G%IdxCu(I,j)) / & - ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) - intx_pa_bk(Ib,jb) = intx_pa_bk(Ib,jb) + intx_dpa_bk(Ib,jb) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + intz_dpa(i,j) = intz_dpa(i,j)*GV%m_to_H enddo ; enddo - ! Compute pressure gradient in y direction - do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk - i = ib+ioff_bk ; J = Jb+joff_bk - PFv(i,J,k) = (((pa_bk(ib,jb)*h(i,j,k) + intz_dpa_bk(ib,jb)) - & - (pa_bk(ib,jb+1)*h(i,j+1,k) + intz_dpa_bk(ib,jb+1))) + & - ((h(i,j+1,k) - h(i,j,k)) * inty_pa_bk(ib,Jb) - & - (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa_bk(ib,Jb) * GV%m_to_H)) * & - ((2.0*I_Rho0*G%IdyCv(i,J)) / & - ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) - inty_pa_bk(ib,Jb) = inty_pa_bk(ib,Jb) + inty_dpa_bk(ib,Jb) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dz(i,j) = GV%g_Earth*GV%H_to_m*h(i,j,k) + dpa(i,j) = (GV%Rlay(k) - rho_ref)*dz(i,j) + intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref)*dz(i,j)*h(i,j,k) enddo ; enddo - do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 - pa_bk(ib,jb) = pa_bk(ib,jb) + dpa_bk(ib,jb) + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_dpa(I,j) = 0.5*(GV%Rlay(k) - rho_ref) * (dz(i,j)+dz(i+1,j)) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_dpa(i,J) = 0.5*(GV%Rlay(k) - rho_ref) * (dz(i,j)+dz(i,j+1)) enddo ; enddo - enddo - - if (CS%GFS_scale < 1.0) then - do k=1,nz - do j=js_bk+joff_bk,je_bk+joff_bk ; do I=Isq_bk+ioff_bk,Ieq_bk+ioff_bk - PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) - enddo ; enddo - do J=Jsq_bk+joff_bk,Jeq_bk+joff_bk ; do i=is_bk+ioff_bk,ie_bk+ioff_bk - PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) - enddo ; enddo - enddo endif + + ! Compute pressure gradient in x direction + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & + (pa(i+1,j)*h(i+1,j,k) + intz_dpa(i+1,j))) + & + ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j) - & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j) * GV%m_to_H)) * & + ((2.0*I_Rho0*G%IdxCu(I,j)) / & + ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) + intx_pa(I,j) = intx_pa(I,j) + intx_dpa(I,j) + enddo ; enddo + ! Compute pressure gradient in y direction + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & + (pa(i,j+1)*h(i,j+1,k) + intz_dpa(i,j+1))) + & + ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J) - & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J) * GV%m_to_H)) * & + ((2.0*I_Rho0*G%IdyCv(i,J)) / & + ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) + inty_pa(i,J) = inty_pa(i,J) + inty_dpa(i,J) + enddo ; enddo + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j) = pa(i,j) + dpa(i,j) + enddo ; enddo enddo + if (CS%GFS_scale < 1.0) then + do k=1,nz + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) + enddo ; enddo + enddo + endif + if (present(pbce)) then call set_pbce_Bouss(e, tv_tmp, G, GV, GV%g_Earth, CS%Rho0, CS%GFS_scale, pbce) endif @@ -752,12 +756,12 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p ! eta is the sea surface height relative to a time-invariant geoid, for ! comparison with what is used for eta in btstep. See how e was calculated ! about 200 lines above. -!$OM parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,eta,e,e_tidal) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta(i,j) = e(i,j,1)*GV%m_to_H + e_tidal(i,j)*GV%m_to_H enddo ; enddo else -!$OM parallel do default(none) shared(Isq,Ieq,Jsq,Jeq,eta,e) + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 eta(i,j) = e(i,j,1)*GV%m_to_H enddo ; enddo @@ -780,6 +784,7 @@ subroutine PressureForce_AFV_init(Time, G, GV, param_file, diag, CS, tides_CSp) ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl ! This module's name. + logical :: use_ALE if (associated(CS)) then call MOM_error(WARNING, "PressureForce_init called with an associated "// & @@ -802,9 +807,30 @@ subroutine PressureForce_AFV_init(Time, G, GV, param_file, diag, CS, tides_CSp) units="kg m-3", default=1035.0) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & + "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If False, use the layered isopycnal algorithm.", default=.false. ) call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & - "If true, use mass weighting when interpolation T/S for\n"//& - "top/bottom integrals in AFV pressure gradient calculation.", default=.false.) + "If true, use mass weighting when interpolating T/S for\n"//& + "integrals near the bathymetry in AFV pressure gradient\n"//& + "calculations.", default=.false.) + call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & + "If True, use vertical reconstruction of T & S within\n"//& + "the integrals of the FV pressure gradient calculation.\n"//& + "If False, use the constant-by-layer algorithm.\n"//& + "The default is set by USE_REGRIDDING.", & + default=use_ALE ) + call get_param(param_file, mdl, "PRESSURE_RECONSTRUCTION_SCHEME", CS%Recon_Scheme, & + "Order of vertical reconstruction of T/S to use in the\n"//& + "integrals within the FV pressure gradient calculation."//& + " 0: PCM or no reconstruction.\n"//& + " 1: PLM reconstruction.\n"//& + " 2: PPM reconstruction.", default=1) + call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, & + "If true, the reconstruction of T & S for pressure in \n"//& + "boundary cells is extrapolated, rather than using PCM \n"//& + "in these cells. If true, the same order polynomial is \n"//& + "used as is used for the interior cells.", default=.true.) if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 new file mode 100644 index 0000000000..1cad7d38c9 --- /dev/null +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -0,0 +1,864 @@ +!> Analytically integrated finite volume pressure gradient +module MOM_PressureForce_blk_AFV + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, time_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss +use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : int_density_dz, int_specific_vol_dp +use MOM_EOS, only : int_density_dz_generic_plm, int_density_dz_generic_ppm +use MOM_EOS, only : int_spec_vol_dp_generic_plm +use MOM_EOS, only : int_density_dz_generic, int_spec_vol_dp_generic +use MOM_ALE, only : pressure_gradient_plm, pressure_gradient_ppm, ALE_CS + +implicit none ; private + +#include + +public PressureForce_blk_AFV, PressureForce_blk_AFV_init, PressureForce_blk_AFV_end +public PressureForce_blk_AFV_Bouss, PressureForce_blk_AFV_nonBouss + +!> Finite volume pressure gradient control structure +type, public :: PressureForce_blk_AFV_CS ; private + logical :: tides !< If true, apply tidal momentum forcing. + real :: Rho0 !< The density used in the Boussinesq + !! approximation, in kg m-3. + real :: GFS_scale !< A scaling of the surface pressure gradients to + !! allow the use of a reduced gravity model. + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the + !! timing of diagnostic output. + logical :: useMassWghtInterp !< Use mass weighting in T/S interpolation + logical :: boundary_extrap !< Indicate whether high-order boundary + !! extrapolation should be used within boundary cells + + logical :: reconstruct !< If true, polynomial profiles of T & S will be + !! reconstructed and used in the integrals for the + !! finite volume pressure gradient calculation. + !! The default depends on whether regridding is being used. + + integer :: Recon_Scheme !< Order of the polynomial of the reconstruction of T & S + !! for the finite volume pressure gradient calculation. + !! By the default (1) is for a piecewise linear method + + integer :: id_e_tidal = -1 !< Diagnostic identifier + type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure +end type PressureForce_blk_AFV_CS + +contains + +!> Thin interface between the model and the Boussinesq and non-Boussinesq +!! pressure force routines. +subroutine PressureForce_blk_AFV(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean + !! or atmosphere-ocean interface in Pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure + !! anomaly in each layer due to eta anomalies, + !! in m2 s-2 H-1. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to + !! calculate PFu and PFv, in H, with any tidal + !! contributions or compressibility compensation. + + if (GV%Boussinesq) then + call PressureForce_blk_AFV_bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) + else + call PressureForce_blk_AFV_nonbouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta) + endif + +end subroutine PressureForce_blk_AFV + +!> \brief Non-Boussinesq analytically-integrated finite volume form of pressure gradient +!! +!! Determines the acceleration due to hydrostatic pressure forces, using the +!! analytic finite volume form of the Pressure gradient, and does not make the +!! Boussinesq approximation. This version uses code-blocking for threads. +!! +!! To work, the following fields must be set outside of the usual +!! ie to ie, je to je range before this subroutine is called: +!! h[ie+1] and h[je+1] and (if tv%eqn_of_state is set) T[ie+1], S[ie+1], +!! T[je+1], and S[je+1]. +subroutine PressureForce_blk_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (kg/m2) + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure + real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean + !! or atmosphere-ocean interface in Pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure + !! anomaly in each layer due to eta anomalies, + !! in m2 s-2 H-1. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to + !! calculate PFu and PFv, in H, with any tidal + !! contributions or compressibility compensation. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: p ! Interface pressure in Pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + T_tmp, & ! Temporary array of temperatures where layers that are lighter + ! than the mixed layer have the mixed layer's properties, in C. + S_tmp ! Temporary array of salinities where layers that are lighter + ! than the mixed layer have the mixed layer's properties, in psu. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + dza, & ! The change in geopotential anomaly between the top and bottom + ! of a layer, in m2 s-2. + intp_dza ! The vertical integral in depth of the pressure anomaly less + ! the pressure anomaly at the top of the layer, in Pa m2 s-2. + real, dimension(SZI_(G),SZJ_(G)) :: & + dp, & ! The (positive) change in pressure across a layer, in Pa. + SSH, & ! The sea surface height anomaly, in m. + e_tidal, & ! The bottom geopotential anomaly due to tidal forces from + ! astronomical sources and self-attraction and loading, in m. + dM, & ! The barotropic adjustment to the Montgomery potential to + ! account for a reduced gravity model, in m2 s-2. + za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the + ! interface atop a layer, in m2 s-2. + real, dimension(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices + dp_bk, & ! The (positive) change in pressure across a layer, in Pa. + za_bk ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the + ! interface atop a layer, in m2 s-2. + + real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable + ! density near-surface layer, in kg m-3. + real, dimension(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices + intx_za_bk ! The zonal integral of the geopotential anomaly along the + ! interface below a layer, divided by the grid spacing, m2 s-2. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: & + intx_dza ! The change in intx_za through a layer, in m2 s-2. + real, dimension(SZDI_(G%Block(1)),SZDJB_(G%Block(1))) :: & ! on block indices + inty_za_bk ! The meridional integral of the geopotential anomaly along the + ! interface below a layer, divided by the grid spacing, m2 s-2. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: & + inty_dza ! The change in inty_za through a layer, in m2 s-2. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density, in Pa (usually 2e7 Pa = 2000 dbar). + + real :: dp_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected, in Pa. + real :: alpha_anom ! The in-situ specific volume, averaged over a + ! layer, less alpha_ref, in m3 kg-1. + logical :: use_p_atm ! If true, use the atmospheric pressure. + logical :: use_EOS ! If true, density is calculated from T & S using an + ! equation of state. + type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. + + real :: alpha_ref ! A reference specific volume, in m3 kg-1, that is used + ! to reduce the impact of truncation errors. + real :: rho_in_situ(SZI_(G)) ! The in situ density, in kg m-3. + real :: Pa_to_H ! A factor to convert from Pa to the thicknesss units (H). +! real :: oneatm = 101325.0 ! 1 atm in Pa (kg/ms2) + real :: I_gEarth + real, parameter :: C1_6 = 1.0/6.0 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: is_bk, ie_bk, js_bk, je_bk, Isq_bk, Ieq_bk, Jsq_bk, Jeq_bk + integer :: i, j, k, n, ib, jb, ioff_bk, joff_bk + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + nkmb=GV%nk_rho_varies + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not.associated(CS)) call MOM_error(FATAL, & + "MOM_PressureForce_AFV_nonBouss: Module must be initialized before it is used.") + + use_p_atm = .false. + if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif + use_EOS = associated(tv%eqn_of_state) + + dp_neglect = GV%H_to_Pa * GV%H_subroundoff + alpha_ref = 1.0/CS%Rho0 + + if (use_p_atm) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + p(i,j,1) = p_atm(i,j) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + p(i,j,1) = 0.0 ! or oneatm + enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do k=2,nz+1 ; do i=Isq,Ieq+1 + p(i,j,K) = p(i,j,K-1) + GV%H_to_Pa * h(i,j,k-1) + enddo ; enddo ; enddo + + I_gEarth = 1.0 / GV%g_Earth + + if (use_EOS) then + ! With a bulk mixed layer, replace the T & S of any layers that are + ! lighter than the the buffer layer with the properties of the buffer + ! layer. These layers will be massless anyway, and it avoids any + ! formal calculations with hydrostatically unstable profiles. + if (nkmb>0) then + tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp + tv_tmp%eqn_of_state => tv%eqn_of_state + do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo + !$OMP parallel do default(shared) private(Rho_cv_BL) + do j=Jsq,Jeq+1 + do k=1,nkmb ; do i=Isq,Ieq+1 + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + enddo ; enddo + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & + Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) + do k=nkmb+1,nz ; do i=Isq,Ieq+1 + if (GV%Rlay(k) < Rho_cv_BL(i)) then + tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) + else + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + enddo + else + tv_tmp%T => tv%T ; tv_tmp%S => tv%S + tv_tmp%eqn_of_state => tv%eqn_of_state + endif + endif + + !$OMP parallel do default(shared) private(alpha_anom,dp) + do k=1,nz + ! Calculate 4 integrals through the layer that are required in the + ! subsequent calculation. + if (use_EOS) then + call int_specific_vol_dp(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), p(:,:,K), & + p(:,:,K+1), alpha_ref, G%HI, tv%eqn_of_state, & + dza(:,:,k), intp_dza(:,:,k), intx_dza(:,:,k), & + inty_dza(:,:,k), bathyP=p(:,:,nz+1), dP_tiny=dp_neglect, & + useMassWghtInterp = CS%useMassWghtInterp) + else + alpha_anom = 1.0/GV%Rlay(k) - alpha_ref + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dp(i,j) = GV%H_to_Pa * h(i,j,k) + dza(i,j,k) = alpha_anom * dp(i,j) + intp_dza(i,j,k) = 0.5 * alpha_anom * dp(i,j)**2 + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + intx_dza(i,j,k) = 0.5 * alpha_anom * (dp(i,j)+dp(i+1,j)) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + inty_dza(i,j,k) = 0.5 * alpha_anom * (dp(i,j)+dp(i,j+1)) + enddo ; enddo + endif + enddo + + ! The bottom geopotential anomaly is calculated first so that the increments + ! to the geopotential anomalies can be reused. Alternately, the surface + ! geopotential could be calculated directly with separate calls to + ! int_specific_vol_dp with alpha_ref=0, and the anomalies used going + ! downward, which would relieve the need for dza, intp_dza, intx_dza, and + ! inty_dza to be 3-D arrays. + + ! Sum vertically to determine the surface geopotential anomaly. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) + enddo + do k=nz,1,-1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) + dza(i,j,k) + enddo ; enddo + enddo + + if (CS%tides) then + ! Find and add the tidal geopotential anomaly. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth + enddo ; enddo + call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth*e_tidal(i,j) + enddo ; enddo + endif + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) private(rho_in_situ) + do j=Jsq,Jeq+1 + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), & + rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) + + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * & + (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) + enddo + enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * & + (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) + enddo ; enddo + endif +! else +! do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; dM(i,j) = 0.0 ; enddo ; enddo + endif + + ! This order of integrating upward and then downward again is necessary with + ! a nonlinear equation of state, so that the surface geopotentials will go + ! linearly between the values at thickness points, but the bottom + ! geopotentials will not now be linear at the sub-grid-scale. Doing this + ! ensures no motion with flat isopycnals, even with a nonlinear equation of state. +!$OMP parallel do default(none) shared(nz,za,G,GV,dza,intx_dza,h,PFu, & +!$OMP intp_dza,p,dp_neglect,inty_dza,PFv,CS,dM) & +!$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & +!$OMP Jeq_bk,ioff_bk,joff_bk,i,j,za_bk,intx_za_bk, & +!$OMP inty_za_bk,dp_bk) + do n = 1, G%nblocks + is_bk=G%block(n)%isc ; ie_bk=G%block(n)%iec + js_bk=G%block(n)%jsc ; je_bk=G%block(n)%jec + Isq_bk=G%block(n)%IscB ; Ieq_bk=G%block(n)%IecB + Jsq_bk=G%block(n)%JscB ; Jeq_bk=G%block(n)%JecB + ioff_bk = G%Block(n)%idg_offset - G%HI%idg_offset + joff_bk = G%Block(n)%jdg_offset - G%HI%jdg_offset + do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 + i = ib+ioff_bk ; j = jb+joff_bk + za_bk(ib,jb) = za(i,j) + enddo ; enddo + do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk + I = Ib+ioff_bk ; j = jb+joff_bk + intx_za_bk(Ib,jb) = 0.5*(za_bk(ib,jb) + za_bk(ib+1,jb)) + enddo ; enddo + do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk + i = ib+ioff_bk ; J = Jb+joff_bk + inty_za_bk(ib,Jb) = 0.5*(za_bk(ib,jb) + za_bk(ib,jb+1)) + enddo ; enddo + do k=1,nz + ! These expressions for the acceleration have been carefully checked in + ! a set of idealized cases, and should be bug-free. + do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 + i = ib+ioff_bk ; j = jb+joff_bk + dp_bk(ib,jb) = GV%H_to_Pa*h(i,j,k) + za_bk(ib,jb) = za_bk(ib,jb) - dza(i,j,k) + enddo ; enddo + do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk + I = Ib+ioff_bk ; j = jb+joff_bk + intx_za_bk(Ib,jb) = intx_za_bk(Ib,jb) - intx_dza(I,j,k) + PFu(I,j,k) = (((za_bk(ib,jb)*dp_bk(ib,jb) + intp_dza(i,j,k)) - & + (za_bk(ib+1,jb)*dp_bk(ib+1,jb) + intp_dza(i+1,j,k))) + & + ((dp_bk(ib+1,jb) - dp_bk(ib,jb)) * intx_za_bk(Ib,jb) - & + (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k))) * & + (2.0*G%IdxCu(I,j) / ((dp_bk(ib,jb) + dp_bk(ib+1,jb)) + & + dp_neglect)) + enddo ; enddo + do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk + i = ib+ioff_bk ; J = Jb+joff_bk + inty_za_bk(ib,Jb) = inty_za_bk(ib,Jb) - inty_dza(i,J,k) + PFv(i,J,k) = (((za_bk(ib,jb)*dp_bk(ib,jb) + intp_dza(i,j,k)) - & + (za_bk(ib,jb+1)*dp_bk(ib,jb+1) + intp_dza(i,j+1,k))) + & + ((dp_bk(ib,jb+1) - dp_bk(ib,jb)) * inty_za_bk(ib,Jb) - & + (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & + (2.0*G%IdyCv(i,J) / ((dp_bk(ib,jb) + dp_bk(ib,jb+1)) + & + dp_neglect)) + enddo ; enddo + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + do j=js_bk+joff_bk,je_bk+joff_bk ; do I=Isq_bk+ioff_bk,Ieq_bk+ioff_bk + PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) + enddo ; enddo + do J=Jsq_bk+joff_bk,Jeq_bk+joff_bk ; do i=is_bk+ioff_bk,ie_bk+ioff_bk + PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) + enddo ; enddo + endif + enddo + enddo + + if (present(pbce)) then + call set_pbce_nonBouss(p, tv_tmp, G, GV, GV%g_Earth, CS%GFS_scale, pbce) + endif + + if (present(eta)) then + Pa_to_H = 1.0 / GV%H_to_Pa + if (use_p_atm) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = (p(i,j,nz+1) - p_atm(i,j))*Pa_to_H ! eta has the same units as h. + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = p(i,j,nz+1)*Pa_to_H ! eta has the same units as h. + enddo ; enddo + endif + endif + + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + +end subroutine PressureForce_blk_AFV_nonBouss + +!> \brief Boussinesq analytically-integrated finite volume form of pressure gradient +!! +!! Determines the acceleration due to hydrostatic pressure forces, using +!! the finite volume form of the terms and analytic integrals in depth, making +!! the Boussinesq approximation. This version uses code-blocking for threads. +!! +!! To work, the following fields must be set outside of the usual +!! ie to ie, je to je range before this subroutine is called: +!! h[ie+1] and h[je+1] and (if tv%eqn_of_state is set) T[ie+1], S[ie+1], +!! T[je+1], and S[je+1]. +subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, pbce, eta) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (kg/m2) + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: PFu !< Zonal acceleration (m/s2) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: PFv !< Meridional acceleration (m/s2) + type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure + real, dimension(:,:), optional, pointer :: p_atm !< The pressure at the ice-ocean + !! or atmosphere-ocean interface in Pa. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: pbce !< The baroclinic pressure + !! anomaly in each layer due to eta anomalies, + !! in m2 s-2 H-1. + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: eta !< The bottom mass used to + !! calculate PFu and PFv, in H, with any tidal + !! contributions or compressibility compensation. + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: e ! Interface height in m. + real, dimension(SZI_(G),SZJ_(G)) :: & + e_tidal, & ! The bottom geopotential anomaly due to tidal forces from + ! astronomical sources and self-attraction and loading, in m. + dM ! The barotropic adjustment to the Montgomery potential to + ! account for a reduced gravity model, in m2 s-2. + real, dimension(SZI_(G)) :: & + Rho_cv_BL ! The coordinate potential density in the deepest variable + ! density near-surface layer, in kg m-3. + real, dimension(SZDI_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices + dz_bk, & ! The change in geopotential thickness through a layer, m2 s-2. + pa_bk, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the + ! the interface atop a layer, in Pa. + dpa_bk, & ! The change in pressure anomaly between the top and bottom + ! of a layer, in Pa. + intz_dpa_bk ! The vertical integral in depth of the pressure anomaly less + ! the pressure anomaly at the top of the layer, in H Pa (m Pa). + real, dimension(SZDIB_(G%Block(1)),SZDJ_(G%Block(1))) :: & ! on block indices + intx_pa_bk, & ! The zonal integral of the pressure anomaly along the interface + ! atop a layer, divided by the grid spacing, in Pa. + intx_dpa_bk ! The change in intx_pa through a layer, in Pa. + real, dimension(SZDI_(G%Block(1)),SZDJB_(G%Block(1))) :: & ! on block indices + inty_pa_bk, & ! The meridional integral of the pressure anomaly along the + ! interface atop a layer, divided by the grid spacing, in Pa. + inty_dpa_bk ! The change in inty_pa through a layer, in Pa. + + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + T_tmp, & ! Temporary array of temperatures where layers that are lighter + ! than the mixed layer have the mixed layer's properties, in C. + S_tmp ! Temporary array of salinities where layers that are lighter + ! than the mixed layer have the mixed layer's properties, in psu. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + S_t, S_b, T_t, T_b ! Top and bottom edge values for linear reconstructions + ! of salinity and temperature within each layer. + real :: rho_in_situ(SZI_(G)) ! The in situ density, in kg m-3. + real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate + ! density, in Pa (usually 2e7 Pa = 2000 dbar). + real :: p0(SZI_(G)) ! An array of zeros to use for pressure in Pa. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected, in m. + real :: I_Rho0 ! 1/Rho0. + real :: G_Rho0 ! G_Earth / Rho0 in m4 s-2 kg-1. + real :: Rho_ref ! The reference density in kg m-3. + real :: dz_neglect ! A minimal thickness in m, like e. + logical :: use_p_atm ! If true, use the atmospheric pressure. + logical :: use_ALE ! If true, use an ALE pressure reconstruction. + logical :: use_EOS ! If true, density is calculated from T & S using an + ! equation of state. + type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. + + real, parameter :: C1_6 = 1.0/6.0 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb + integer :: is_bk, ie_bk, js_bk, je_bk, Isq_bk, Ieq_bk, Jsq_bk, Jeq_bk + integer :: ioff_bk, joff_bk + integer :: i, j, k, n, ib, jb + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + nkmb=GV%nk_rho_varies + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + if (.not.associated(CS)) call MOM_error(FATAL, & + "MOM_PressureForce_AFV_Bouss: Module must be initialized before it is used.") + + use_p_atm = .false. + if (present(p_atm)) then ; if (associated(p_atm)) use_p_atm = .true. ; endif + use_EOS = associated(tv%eqn_of_state) + do i=Isq,Ieq+1 ; p0(i) = 0.0 ; enddo + use_ALE = .false. + if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS + + h_neglect = GV%H_subroundoff + dz_neglect = GV%H_subroundoff * GV%H_to_m + I_Rho0 = 1.0/GV%Rho0 + G_Rho0 = GV%g_Earth/GV%Rho0 + rho_ref = CS%Rho0 + + if (CS%tides) then + ! Determine the surface height anomaly for calculating self attraction + ! and loading. This should really be based on bottom pressure anomalies, + ! but that is not yet implemented, and the current form is correct for + ! barotropic tides. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + e(i,j,1) = -1.0*G%bathyT(i,j) + enddo + do k=1,nz ; do i=Isq,Ieq+1 + e(i,j,1) = e(i,j,1) + h(i,j,k)*GV%H_to_m + enddo ; enddo + enddo + call calc_tidal_forcing(CS%Time, e(:,:,1), e_tidal, G, CS%tides_CSp) + endif + +! Here layer interface heights, e, are calculated. + if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -1.0*G%bathyT(i,j) - e_tidal(i,j) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -1.0*G%bathyT(i,j) + enddo ; enddo + endif + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1; do k=nz,1,-1 ; do i=Isq,Ieq+1 + e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_m + enddo ; enddo ; enddo + + + if (use_EOS) then +! With a bulk mixed layer, replace the T & S of any layers that are +! lighter than the the buffer layer with the properties of the buffer +! layer. These layers will be massless anyway, and it avoids any +! formal calculations with hydrostatically unstable profiles. + + if (nkmb>0) then + tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp + tv_tmp%eqn_of_state => tv%eqn_of_state + + do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo + !$OMP parallel do default(shared) private(Rho_cv_BL) + do j=Jsq,Jeq+1 + do k=1,nkmb ; do i=Isq,Ieq+1 + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + enddo ; enddo + call calculate_density(tv%T(:,j,nkmb), tv%S(:,j,nkmb), p_ref, & + Rho_cv_BL(:), Isq, Ieq-Isq+2, tv%eqn_of_state) + + do k=nkmb+1,nz ; do i=Isq,Ieq+1 + if (GV%Rlay(k) < Rho_cv_BL(i)) then + tv_tmp%T(i,j,k) = tv%T(i,j,nkmb) ; tv_tmp%S(i,j,k) = tv%S(i,j,nkmb) + else + tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) + endif + enddo ; enddo + enddo + else + tv_tmp%T => tv%T ; tv_tmp%S => tv%S + tv_tmp%eqn_of_state => tv%eqn_of_state + endif + endif + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + if (use_p_atm) then + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), & + rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) + else + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, & + rho_in_situ, Isq, Ieq-Isq+2, tv%eqn_of_state) + endif + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * e(i,j,1) + enddo + enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * e(i,j,1) + enddo ; enddo + endif + endif + ! I have checked that rho_0 drops out and that the 1-layer case is right. RWH. + + ! If regridding is activated, do a linear reconstruction of salinity + ! and temperature across each layer. The subscripts 't' and 'b' refer + ! to top and bottom values within each layer (these are the only degrees + ! of freedeom needed to know the linear profile). + if ( use_ALE ) then + if ( CS%Recon_Scheme == 1 ) then + call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + elseif ( CS%Recon_Scheme == 2 ) then + call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + endif + endif + +!$OMP parallel do default(none) shared(use_p_atm,rho_ref,G,GV,e,p_atm,nz,use_EOS,& +!$OMP use_ALE,T_t,T_b,S_t,S_b,CS,tv,tv_tmp, & +!$OMP h,PFu,I_Rho0,h_neglect,dz_neglect,PFv,dM)& +!$OMP private(is_bk,ie_bk,js_bk,je_bk,Isq_bk,Ieq_bk,Jsq_bk, & +!$OMP Jeq_bk,ioff_bk,joff_bk,pa_bk, & +!$OMP intx_pa_bk,inty_pa_bk,dpa_bk,intz_dpa_bk, & +!$OMP intx_dpa_bk,inty_dpa_bk,dz_bk,i,j) + do n = 1, G%nblocks + is_bk=G%Block(n)%isc ; ie_bk=G%Block(n)%iec + js_bk=G%Block(n)%jsc ; je_bk=G%Block(n)%jec + Isq_bk=G%Block(n)%IscB ; Ieq_bk=G%Block(n)%IecB + Jsq_bk=G%Block(n)%JscB ; Jeq_bk=G%Block(n)%JecB + ioff_bk = G%Block(n)%idg_offset - G%HI%idg_offset + joff_bk = G%Block(n)%jdg_offset - G%HI%jdg_offset + + ! Set the surface boundary conditions on pressure anomaly and its horizontal + ! integrals, assuming that the surface pressure anomaly varies linearly + ! in x and y. + if (use_p_atm) then + do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 + i = ib+ioff_bk ; j = jb+joff_bk + pa_bk(ib,jb) = (rho_ref*GV%g_Earth)*e(i,j,1) + p_atm(i,j) + enddo ; enddo + else + do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 + i = ib+ioff_bk ; j = jb+joff_bk + pa_bk(ib,jb) = (rho_ref*GV%g_Earth)*e(i,j,1) + enddo ; enddo + endif + do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk + intx_pa_bk(Ib,jb) = 0.5*(pa_bk(ib,jb) + pa_bk(ib+1,jb)) + enddo ; enddo + do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk + inty_pa_bk(ib,Jb) = 0.5*(pa_bk(ib,jb) + pa_bk(ib,jb+1)) + enddo ; enddo + + do k=1,nz + ! Calculate 4 integrals through the layer that are required in the + ! subsequent calculation. + + if (use_EOS) then + ! The following routine computes the integrals that are needed to + ! calculate the pressure gradient force. Linear profiles for T and S are + ! assumed when regridding is activated. Otherwise, the previous version + ! is used, whereby densities within each layer are constant no matter + ! where the layers are located. + if ( use_ALE ) then + if ( CS%Recon_Scheme == 1 ) then + call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), & + S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, GV%g_Earth, & + dz_neglect, G%bathyT, G%HI, G%Block(n), & + tv%eqn_of_state, dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & + useMassWghtInterp = CS%useMassWghtInterp) + elseif ( CS%Recon_Scheme == 2 ) then + call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & + tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, GV%g_Earth, & + G%HI, G%Block(n), tv%eqn_of_state, dpa_bk, intz_dpa_bk, & + intx_dpa_bk, inty_dpa_bk) + endif + else + call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), & + e(:,:,K), e(:,:,K+1), & + rho_ref, CS%Rho0, GV%g_Earth, G%HI, G%Block(n), tv%eqn_of_state, & + dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & + G%bathyT, dz_neglect, CS%useMassWghtInterp) + endif + do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 + intz_dpa_bk(ib,jb) = intz_dpa_bk(ib,jb)*GV%m_to_H + enddo ; enddo + else + do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 + i = ib+ioff_bk ; j = jb+joff_bk + dz_bk(ib,jb) = GV%g_Earth*GV%H_to_m*h(i,j,k) + dpa_bk(ib,jb) = (GV%Rlay(k) - rho_ref)*dz_bk(ib,jb) + intz_dpa_bk(ib,jb) = 0.5*(GV%Rlay(k) - rho_ref)*dz_bk(ib,jb)*h(i,j,k) + enddo ; enddo + do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk + intx_dpa_bk(Ib,jb) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib+1,jb)) + enddo ; enddo + do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk + inty_dpa_bk(ib,Jb) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_bk(ib,jb)+dz_bk(ib,jb+1)) + enddo ; enddo + endif + + ! Compute pressure gradient in x direction + do jb=js_bk,je_bk ; do Ib=Isq_bk,Ieq_bk + I = Ib+ioff_bk ; j = jb+joff_bk + PFu(I,j,k) = (((pa_bk(ib,jb)*h(i,j,k) + intz_dpa_bk(ib,jb)) - & + (pa_bk(ib+1,jb)*h(i+1,j,k) + intz_dpa_bk(ib+1,jb))) + & + ((h(i+1,j,k) - h(i,j,k)) * intx_pa_bk(Ib,jb) - & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa_bk(Ib,jb) * GV%m_to_H)) * & + ((2.0*I_Rho0*G%IdxCu(I,j)) / & + ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) + intx_pa_bk(Ib,jb) = intx_pa_bk(Ib,jb) + intx_dpa_bk(Ib,jb) + enddo ; enddo + ! Compute pressure gradient in y direction + do Jb=Jsq_bk,Jeq_bk ; do ib=is_bk,ie_bk + i = ib+ioff_bk ; J = Jb+joff_bk + PFv(i,J,k) = (((pa_bk(ib,jb)*h(i,j,k) + intz_dpa_bk(ib,jb)) - & + (pa_bk(ib,jb+1)*h(i,j+1,k) + intz_dpa_bk(ib,jb+1))) + & + ((h(i,j+1,k) - h(i,j,k)) * inty_pa_bk(ib,Jb) - & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa_bk(ib,Jb) * GV%m_to_H)) * & + ((2.0*I_Rho0*G%IdyCv(i,J)) / & + ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) + inty_pa_bk(ib,Jb) = inty_pa_bk(ib,Jb) + inty_dpa_bk(ib,Jb) + enddo ; enddo + do jb=Jsq_bk,Jeq_bk+1 ; do ib=Isq_bk,Ieq_bk+1 + pa_bk(ib,jb) = pa_bk(ib,jb) + dpa_bk(ib,jb) + enddo ; enddo + enddo + + if (CS%GFS_scale < 1.0) then + do k=1,nz + do j=js_bk+joff_bk,je_bk+joff_bk ; do I=Isq_bk+ioff_bk,Ieq_bk+ioff_bk + PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) + enddo ; enddo + do J=Jsq_bk+joff_bk,Jeq_bk+joff_bk ; do i=is_bk+ioff_bk,ie_bk+ioff_bk + PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) + enddo ; enddo + enddo + endif + enddo + + if (present(pbce)) then + call set_pbce_Bouss(e, tv_tmp, G, GV, GV%g_Earth, CS%Rho0, CS%GFS_scale, pbce) + endif + + if (present(eta)) then + if (CS%tides) then + ! eta is the sea surface height relative to a time-invariant geoid, for + ! comparison with what is used for eta in btstep. See how e was calculated + ! about 200 lines above. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%m_to_H + e_tidal(i,j)*GV%m_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%m_to_H + enddo ; enddo + endif + endif + + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + +end subroutine PressureForce_blk_AFV_Bouss + +!> Initializes the finite volume pressure gradient control structure +subroutine PressureForce_blk_AFV_init(Time, G, GV, param_file, diag, CS, tides_CSp) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(param_file_type), intent(in) :: param_file !< Parameter file handles + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(PressureForce_blk_AFV_CS), pointer :: CS !< Finite volume PGF control structure + type(tidal_forcing_CS), optional, pointer :: tides_CSp !< Tides control structure +! This include declares and sets the variable "version". +#include "version_variable.h" + character(len=40) :: mdl ! This module's name. + logical :: use_ALE + + if (associated(CS)) then + call MOM_error(WARNING, "PressureForce_init called with an associated "// & + "control structure.") + return + else ; allocate(CS) ; endif + + CS%diag => diag ; CS%Time => Time + if (present(tides_CSp)) then + if (associated(tides_CSp)) CS%tides_CSp => tides_CSp + endif + + mdl = "MOM_PressureForce_blk_AFV" + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + "The mean ocean density used with BOUSSINESQ true to \n"//& + "calculate accelerations and the mass for conservation \n"//& + "properties, or with BOUSSINSEQ false to convert some \n"//& + "parameters from vertical units of m to kg m-2.", & + units="kg m-3", default=1035.0) + call get_param(param_file, mdl, "TIDES", CS%tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & + "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(param_file, mdl, "MASS_WEIGHT_IN_PRESSURE_GRADIENT", CS%useMassWghtInterp, & + "If true, use mass weighting when interpolating T/S for\n"//& + "integrals near the bathymetry in AFV pressure gradient\n"//& + "calculations.", default=.false.) + call get_param(param_file, mdl, "RECONSTRUCT_FOR_PRESSURE", CS%reconstruct, & + "If True, use vertical reconstruction of T & S within\n"//& + "the integrals of the FV pressure gradient calculation.\n"//& + "If False, use the constant-by-layer algorithm.\n"//& + "The default is set by USE_REGRIDDING.", & + default=use_ALE ) + call get_param(param_file, mdl, "PRESSURE_RECONSTRUCTION_SCHEME", CS%Recon_Scheme, & + "Order of vertical reconstruction of T/S to use in the\n"//& + "integrals within the FV pressure gradient calculation."//& + " 0: PCM or no reconstruction.\n"//& + " 1: PLM reconstruction.\n"//& + " 2: PPM reconstruction.", default=1) + call get_param(param_file, mdl, "BOUNDARY_EXTRAPOLATION_PRESSURE", CS%boundary_extrap, & + "If true, the reconstruction of T & S for pressure in \n"//& + "boundary cells is extrapolated, rather than using PCM \n"//& + "in these cells. If true, the same order polynomial is \n"//& + "used as is used for the interior cells.", default=.true.) + + if (CS%tides) then + CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & + Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter') + endif + + CS%GFS_scale = 1.0 + if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth + + call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) + +end subroutine PressureForce_blk_AFV_init + +!> Deallocates the finite volume pressure gradient control structure +subroutine PressureForce_blk_AFV_end(CS) + type(PressureForce_blk_AFV_CS), pointer :: CS + if (associated(CS)) deallocate(CS) +end subroutine PressureForce_blk_AFV_end + +!> \namespace mom_pressureforce_afv +!! +!! Provides the Boussinesq and non-Boussinesq forms of horizontal accelerations +!! due to pressure gradients using a 2nd-order analytically vertically integrated +!! finite volume form, as described by Adcroft et al., 2008. +!! +!! This form eliminates the thermobaric instabilities that had been a problem with +!! previous forms of the pressure gradient force calculation, as described by +!! Hallberg, 2005. +!! +!! Adcroft, A., R. Hallberg, and M. Harrison, 2008: A finite volume discretization +!! of the pressure gradient force using analytic integration. Ocean Modelling, 22, +!! 106-113. http://doi.org/10.1016/j.ocemod.2008.02.001 +!! +!! Hallberg, 2005: A thermobaric instability of Lagrangian vertical coordinate +!! ocean models. Ocean Modelling, 8, 279-300. +!! http://dx.doi.org/10.1016/j.ocemod.2004.01.001 + +end module MOM_PressureForce_blk_AFV diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 7d0127b8ff..4c91ef2edb 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -162,172 +162,172 @@ module MOM_barotropic ! frhatu and frhatv are the fraction of the total column thickness ! interpolated to u or v grid points in each layer, nondimensional. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & - IDatu, & ! Inverse of the basin depth at u grid points, in m-1. - lin_drag_u, & ! A spatially varying linear drag coefficient acting - ! on the zonal barotropic flow, in H s-1. - uhbt_IC, & ! The barotropic solver's estimate of the zonal - ! transport as the initial condition for the next call - ! to btstep, in H m2 s-1. - ubt_IC, & ! The barotropic solver's estimate of the zonal velocity - ! that will be the initial condition for the next call - ! to btstep, in m s-1. - ubtav ! The barotropic zonal velocity averaged over the - ! baroclinic time step, m s-1. + IDatu, & !< Inverse of the basin depth at u grid points, in m-1. + lin_drag_u, & !< A spatially varying linear drag coefficient acting + !! on the zonal barotropic flow, in H s-1. + uhbt_IC, & !< The barotropic solver's estimate of the zonal + !! transport as the initial condition for the next call + !! to btstep, in H m2 s-1. + ubt_IC, & !< The barotropic solver's estimate of the zonal velocity + !! that will be the initial condition for the next call + !! to btstep, in m s-1. + ubtav !< The barotropic zonal velocity averaged over the + !! baroclinic time step, m s-1. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & - IDatv, & ! Inverse of the basin depth at v grid points, in m-1. - lin_drag_v, & ! A spatially varying linear drag coefficient acting - ! on the zonal barotropic flow, in H s-1. - vhbt_IC, & ! The barotropic solver's estimate of the zonal - ! transport as the initla condition for the next call - ! to btstep, in H m2 s-1. - vbt_IC, & ! The barotropic solver's estimate of the zonal velocity - ! that will be the initial condition for the next call - ! to btstep, in m s-1. - vbtav ! The barotropic meridional velocity averaged over the - ! baroclinic time step, m s-1. + IDatv, & !< Inverse of the basin depth at v grid points, in m-1. + lin_drag_v, & !< A spatially varying linear drag coefficient acting + !! on the zonal barotropic flow, in H s-1. + vhbt_IC, & !< The barotropic solver's estimate of the zonal + !! transport as the initla condition for the next call + !! to btstep, in H m2 s-1. + vbt_IC, & !< The barotropic solver's estimate of the zonal velocity + !! that will be the initial condition for the next call + !! to btstep, in m s-1. + vbtav !< The barotropic meridional velocity averaged over the + !! baroclinic time step, m s-1. real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - eta_cor, & ! The difference between the free surface height from - ! the barotropic calculation and the sum of the layer - ! thicknesses. This difference is imposed as a forcing - ! term in the barotropic calculation over a baroclinic - ! timestep, in H (m or kg m-2). - eta_cor_bound ! A limit on the rate at which eta_cor can be applied - ! while avoiding instability, in units of H s-1. This - ! is only used if CS%bound_BT_corr is true. + eta_cor, & !< The difference between the free surface height from + !! the barotropic calculation and the sum of the layer + !! thicknesses. This difference is imposed as a forcing + !! term in the barotropic calculation over a baroclinic + !! timestep, in H (m or kg m-2). + eta_cor_bound !< A limit on the rate at which eta_cor can be applied + !! while avoiding instability, in units of H s-1. This + !! is only used if CS%bound_BT_corr is true. real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: & - ua_polarity, & ! Test vector components for checking grid polarity. - va_polarity, & ! Test vector components for checking grid polarity. - bathyT ! A copy of bathyT (ocean bottom depth) with wide halos. + ua_polarity, & !< Test vector components for checking grid polarity. + va_polarity, & !< Test vector components for checking grid polarity. + bathyT !< A copy of bathyT (ocean bottom depth) with wide halos. real ALLOCABLE_, dimension(NIMEMW_,NJMEMW_) :: & - IareaT ! This is a copy of G%IareaT with wide halos, but will - ! still utilize the macro IareaT when referenced, m-2. + IareaT !< This is a copy of G%IareaT with wide halos, but will + !! still utilize the macro IareaT when referenced, m-2. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMW_) :: & - D_u_Cor, & ! A simply averaged depth at u points, in m. - dy_Cu, & ! A copy of G%dy_Cu with wide halos, in m. - IdxCu ! A copy of G%IdxCu with wide halos, in m-1. + D_u_Cor, & !< A simply averaged depth at u points, in m. + dy_Cu, & !< A copy of G%dy_Cu with wide halos, in m. + IdxCu !< A copy of G%IdxCu with wide halos, in m-1. real ALLOCABLE_, dimension(NIMEMW_,NJMEMBW_) :: & - D_v_Cor, & ! A simply averaged depth at v points, in m. - dx_Cv, & ! A copy of G%dx_Cv with wide halos, in m. - IdyCv ! A copy of G%IdyCv with wide halos, in m-1. + D_v_Cor, & !< A simply averaged depth at v points, in m. + dx_Cv, & !< A copy of G%dx_Cv with wide halos, in m. + IdyCv !< A copy of G%IdyCv with wide halos, in m-1. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMBW_) :: & - q_D ! f / D at PV points, in m-1 s-1. + q_D !< f / D at PV points, in m-1 s-1. - real, pointer, dimension(:,:,:) :: frhatu1 => NULL(), frhatv1 => NULL() ! Predictor values. + real, dimension(:,:,:), pointer :: frhatu1 => NULL(), frhatv1 => NULL() ! Predictor values. type(BT_OBC_type) :: BT_OBC !< A structure with all of this module's fields !! for applying open boundary conditions. - real :: Rho0 ! The density used in the Boussinesq - ! approximation, in kg m-3. - real :: dtbt ! The barotropic time step, in s. - real :: dtbt_fraction ! The fraction of the maximum time-step that - ! should used. The default is 0.98. - real :: dtbt_max ! The maximum stable barotropic time step, in s. - real :: dt_bt_filter ! The time-scale over which the barotropic mode - ! solutions are filtered, in s. This can never - ! be taken to be longer than 2*dt. The default, 0, - ! applies no filtering. - integer :: nstep_last = 0 ! The number of barotropic timesteps per baroclinic - ! time step the last time btstep was called. - real :: bebt ! A nondimensional number, from 0 to 1, that - ! determines the gravity wave time stepping scheme. - ! 0.0 gives a forward-backward scheme, while 1.0 - ! give backward Euler. In practice, bebt should be - ! of order 0.2 or greater. - logical :: split ! If true, use the split time stepping scheme. - logical :: bound_BT_corr ! If true, the magnitude of the fake mass source - ! in the barotropic equation that drives the two - ! estimates of the free surface height toward each - ! other is bounded to avoid driving corrective - ! velocities that exceed MAXCFL_BT_CONT. - logical :: gradual_BT_ICs ! If true, adjust the initial conditions for the - ! barotropic solver to the values from the layered - ! solution over a whole timestep instead of - ! instantly. This is a decent approximation to the - ! inclusion of sum(u dh_dt) while also correcting - ! for truncation errors. - logical :: Sadourny ! If true, the Coriolis terms are discretized - ! with Sadourny's energy conserving scheme, - ! otherwise the Arakawa & Hsu scheme is used. If - ! the deformation radius is not resolved Sadourny's - ! scheme should probably be used. - logical :: Nonlinear_continuity ! If true, the barotropic continuity equation - ! uses the full ocean thickness for transport. - integer :: Nonlin_cont_update_period ! The number of barotropic time steps - ! between updates to the face area, or 0 only to - ! update at the start of a call to btstep. The - ! default is 1. - logical :: BT_project_velocity ! If true, step the barotropic velocity first - ! and project out the velocity tendancy by 1+BEBT - ! when calculating the transport. The default - ! (false) is to use a predictor continuity step to - ! find the pressure field, and then do a corrector - ! continuity step using a weighted average of the - ! old and new velocities, with weights of (1-BEBT) - ! and BEBT. - logical :: dynamic_psurf ! If true, add a dynamic pressure due to a viscous - ! ice shelf, for instance. - real :: Dmin_dyn_psurf ! The minimum depth to use in limiting the size - ! of the dynamic surface pressure for stability, - ! in m. - real :: ice_strength_length ! The length scale at which the damping rate - ! due to the ice strength should be the same as if - ! a Laplacian were applied, in m. - real :: const_dyn_psurf ! The constant that scales the dynamic surface - ! pressure, nondim. Stable values are < ~1.0. - ! The default is 0.9. - logical :: tides ! If true, apply tidal momentum forcing. - real :: G_extra ! A nondimensional factor by which gtot is enhanced. - integer :: hvel_scheme ! An integer indicating how the thicknesses at - ! velocity points are calculated. Valid values are - ! given by the parameters defined below: - ! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT - logical :: strong_drag ! If true, use a stronger estimate of the retarding - ! effects of strong bottom drag. - logical :: linear_wave_drag ! If true, apply a linear drag to the barotropic - ! velocities, using rates set by lin_drag_u & _v - ! divided by the depth of the ocean. - logical :: linearized_BT_PV ! If true, the PV and interface thicknesses used - ! in the barotropic Coriolis calculation is time - ! invariant and linearized. - logical :: use_wide_halos ! If true, use wide halos and march in during the - ! barotropic time stepping for efficiency. - logical :: clip_velocity ! If true, limit any velocity components that are - ! are large enough for a CFL number to exceed - ! CFL_trunc. This should only be used as a - ! desperate debugging measure. - logical :: debug ! If true, write verbose checksums for debugging purposes. - logical :: debug_bt ! If true, write verbose checksums for debugging purposes. + real :: Rho0 !< The density used in the Boussinesq + !! approximation, in kg m-3. + real :: dtbt !< The barotropic time step, in s. + real :: dtbt_fraction !< The fraction of the maximum time-step that + !! should used. The default is 0.98. + real :: dtbt_max !< The maximum stable barotropic time step, in s. + real :: dt_bt_filter !< The time-scale over which the barotropic mode + !! solutions are filtered, in s. This can never + !! be taken to be longer than 2*dt. The default, 0, + !! applies no filtering. + integer :: nstep_last = 0 !< The number of barotropic timesteps per baroclinic + !! time step the last time btstep was called. + real :: bebt !< A nondimensional number, from 0 to 1, that + !! determines the gravity wave time stepping scheme. + !! 0.0 gives a forward-backward scheme, while 1.0 + !! give backward Euler. In practice, bebt should be + !! of order 0.2 or greater. + logical :: split !< If true, use the split time stepping scheme. + logical :: bound_BT_corr !< If true, the magnitude of the fake mass source + !! in the barotropic equation that drives the two + !! estimates of the free surface height toward each + !! other is bounded to avoid driving corrective + !! velocities that exceed MAXCFL_BT_CONT. + logical :: gradual_BT_ICs !< If true, adjust the initial conditions for the + !! barotropic solver to the values from the layered + !! solution over a whole timestep instead of + !! instantly. This is a decent approximation to the + !! inclusion of sum(u dh_dt) while also correcting + !! for truncation errors. + logical :: Sadourny !< If true, the Coriolis terms are discretized + !! with Sadourny's energy conserving scheme, + !! otherwise the Arakawa & Hsu scheme is used. If + !! the deformation radius is not resolved Sadourny's + !! scheme should probably be used. + logical :: Nonlinear_continuity !< If true, the barotropic continuity equation + !! uses the full ocean thickness for transport. + integer :: Nonlin_cont_update_period !< The number of barotropic time steps + !! between updates to the face area, or 0 only to + !! update at the start of a call to btstep. The + !! default is 1. + logical :: BT_project_velocity !< If true, step the barotropic velocity first + !! and project out the velocity tendancy by 1+BEBT + !! when calculating the transport. The default + !! (false) is to use a predictor continuity step to + !! find the pressure field, and then do a corrector + !! continuity step using a weighted average of the + !! old and new velocities, with weights of (1-BEBT) + !! and BEBT. + logical :: dynamic_psurf !< If true, add a dynamic pressure due to a viscous + !! ice shelf, for instance. + real :: Dmin_dyn_psurf !< The minimum depth to use in limiting the size + !! of the dynamic surface pressure for stability, + !! in m. + real :: ice_strength_length !< The length scale at which the damping rate + !! due to the ice strength should be the same as if + !! a Laplacian were applied, in m. + real :: const_dyn_psurf !< The constant that scales the dynamic surface + !! pressure, nondim. Stable values are < ~1.0. + !! The default is 0.9. + logical :: tides !< If true, apply tidal momentum forcing. + real :: G_extra !< A nondimensional factor by which gtot is enhanced. + integer :: hvel_scheme !< An integer indicating how the thicknesses at + !! velocity points are calculated. Valid values are + !! given by the parameters defined below: + !! HARMONIC, ARITHMETIC, HYBRID, and FROM_BT_CONT + logical :: strong_drag !< If true, use a stronger estimate of the retarding + !! effects of strong bottom drag. + logical :: linear_wave_drag !< If true, apply a linear drag to the barotropic + !! velocities, using rates set by lin_drag_u & _v + !! divided by the depth of the ocean. + logical :: linearized_BT_PV !< If true, the PV and interface thicknesses used + !! in the barotropic Coriolis calculation is time + !! invariant and linearized. + logical :: use_wide_halos !< If true, use wide halos and march in during the + !! barotropic time stepping for efficiency. + logical :: clip_velocity !< If true, limit any velocity components that are + !! are large enough for a CFL number to exceed + !! CFL_trunc. This should only be used as a + !! desperate debugging measure. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_bt !< If true, write verbose checksums for debugging purposes. real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0, in m s-1. - real :: maxvel ! Velocity components greater than maxvel are - ! truncated to maxvel, in m s-1. - real :: CFL_trunc ! If clip_velocity is true, velocity components will - ! be truncated when they are large enough that the - ! corresponding CFL number exceeds this value, nondim. - real :: maxCFL_BT_cont ! The maximum permitted CFL number associated with the - ! barotropic accelerations from the summed velocities - ! times the time-derivatives of thicknesses. The - ! default is 0.1, and there will probably be real - ! problems if this were set close to 1. - logical :: BT_cont_bounds ! If true, use the BT_cont_type variables to set - ! limits on the magnitude of the corrective mass - ! fluxes. - logical :: visc_rem_u_uh0 ! If true, use the viscous remnants when estimating - ! the barotropic velocities that were used to - ! calculate uh0 and vh0. False is probably the - ! better choice. - logical :: adjust_BT_cont ! If true, adjust the curve fit to the BT_cont type - ! that is used by the barotropic solver to match the - ! transport about which the flow is being linearized. + real :: maxvel !< Velocity components greater than maxvel are + !! truncated to maxvel, in m s-1. + real :: CFL_trunc !< If clip_velocity is true, velocity components will + !! be truncated when they are large enough that the + !! corresponding CFL number exceeds this value, nondim. + real :: maxCFL_BT_cont !< The maximum permitted CFL number associated with the + !! barotropic accelerations from the summed velocities + !! times the time-derivatives of thicknesses. The + !! default is 0.1, and there will probably be real + !! problems if this were set close to 1. + logical :: BT_cont_bounds !< If true, use the BT_cont_type variables to set + !! limits on the magnitude of the corrective mass + !! fluxes. + logical :: visc_rem_u_uh0 !< If true, use the viscous remnants when estimating + !! the barotropic velocities that were used to + !! calculate uh0 and vh0. False is probably the + !! better choice. + logical :: adjust_BT_cont !< If true, adjust the curve fit to the BT_cont type + !! that is used by the barotropic solver to match the + !! transport about which the flow is being linearized. logical :: use_old_coriolis_bracket_bug !< If True, use an order of operations !! that is not bitwise rotationally symmetric in the !! meridional Coriolis term of the barotropic solver. - type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the - ! timing of diagnostic output. + type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate + !! the timing of diagnostic output. type(MOM_domain_type), pointer :: BT_Domain => NULL() - type(hor_index_type), pointer :: debug_BT_HI ! debugging copy of horizontal index_type + type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type type(tidal_forcing_CS), pointer :: tides_CSp => NULL() logical :: module_is_initialized = .false. @@ -448,21 +448,25 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & !! viscosity is applied, in the zonal direction. Nondimensional !! between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: visc_rem_v !< Ditto for meridional direction. - real, dimension(SZI_(G),SZJ_(G)), intent(out), optional :: etaav !< The free surface height or column mass + real, dimension(SZI_(G),SZJ_(G)), optional, intent(out) :: etaav !< The free surface height or column mass !! averaged over the barotropic integration, in m or kg m-2. - type(ocean_OBC_type), pointer, optional :: OBC !< The open boundary condition structure. - type(BT_cont_type), pointer, optional :: BT_cont !< A structure with elements that describe + type(ocean_OBC_type), optional, pointer :: OBC !< The open boundary condition structure. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic !! flow. - real, dimension(:,:), pointer, optional :: eta_PF_start !< The eta field consistent with the pressure + real, dimension(:,:), optional, pointer :: eta_PF_start !< The eta field consistent with the pressure !! gradient at the start of the barotropic stepping, in m or !! kg m-2. - real, dimension(:,:), pointer, optional :: taux_bot !< The zonal bottom frictional stress from + real, dimension(:,:), optional, pointer :: taux_bot !< The zonal bottom frictional stress from !! ocean to the seafloor, in Pa. - real, dimension(:,:), pointer, optional :: tauy_bot !< The meridional bottom frictional stress + real, dimension(:,:), optional, pointer :: tauy_bot !< The meridional bottom frictional stress !! from ocean to the seafloor, in Pa. - real, dimension(:,:,:), pointer, optional :: uh0, u_uh0 - real, dimension(:,:,:), pointer, optional :: vh0, v_vh0 + real, dimension(:,:,:), optional, pointer :: uh0 !< The zonal layer transports at reference + !! velocities, in H m s-1. + real, dimension(:,:,:), optional, pointer :: u_uh0 !< The velocities used to calculate uh0, in m s-1 + real, dimension(:,:,:), optional, pointer :: vh0 !< The zonal layer transports at reference + !! velocities, in H m s-1. + real, dimension(:,:,:), optional, pointer :: v_vh0 !< The velocities used to calculate vh0, in m s-1 ! Local variables real :: ubt_Cor(SZIB_(G),SZJ_(G)) ! The barotropic velocities that had been @@ -554,7 +558,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & eta, & ! The barotropic free surface height anomaly or column mass ! anomaly, in H (m or kg m-2) eta_pred ! A predictor value of eta, in H (m or kg m-2) like eta. - real, pointer, dimension(:,:) :: & + real, dimension(:,:), pointer :: & eta_PF_BT ! A pointer to the eta array (either eta or eta_pred) that ! determines the barotropic pressure force, in H (m or kg m-2) real, dimension(SZIW_(CS),SZJW_(CS)) :: & @@ -1422,7 +1426,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & (CS%ice_strength_length**2 * dtbt) ! Units of dyn_coef: m2 s-2 H-1 - dyn_coef_eta(I,j) = min(dyn_coef_max, ice_strength * GV%H_to_m) + dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * GV%H_to_m) enddo ; enddo ; endif endif @@ -1627,7 +1631,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, & if (CS%dynamic_psurf) then !GOMP do do j=jsv-1,jev+1 ; do i=isv-1,iev+1 - p_surf_dyn(i,j) = dyn_coef_eta(I,j) * (eta_pred(i,j) - eta(i,j)) + p_surf_dyn(i,j) = dyn_coef_eta(i,j) * (eta_pred(i,j) - eta(i,j)) enddo ; enddo endif endif @@ -2277,22 +2281,24 @@ end subroutine btstep !> This subroutine automatically determines an optimal value for dtbt based !! on some state of the ocean. subroutine set_dtbt(G, GV, CS, eta, pbce, BT_cont, gtot_est, SSH_add) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(barotropic_CS), pointer :: CS !< Barotropic control structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in), optional :: eta !< The barotropic free surface height - !! anomaly or column mass anomaly, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: pbce !< The baroclinic pressure anomaly in each - !! layer due to free surface height - !! anomalies, in m2 H-1 s-2. - type(BT_cont_type), pointer, optional :: BT_cont !< A structure with elements that describe - !! the effective open face areas as a - !! function of barotropic flow. - real, intent(in), optional :: gtot_est !< An estimate of the total gravitational - !! acceleration, in m s-2. - real, intent(in), optional :: SSH_add !< An additional contribution to SSH to - !! provide a margin of error when - !! calculating the external wave speed, in m. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(barotropic_CS), pointer :: CS !< Barotropic control structure. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: eta !< The barotropic free surface height + !! anomaly or column mass anomaly, in H. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: pbce !< The baroclinic pressure anomaly in each + !! layer due to free surface height + !! anomalies, in m2 H-1 s-2. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a + !! function of barotropic flow. + real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational + !! acceleration, in m s-2. + real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to + !! provide a margin of error when + !! calculating the external wave speed, in m. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & @@ -2304,10 +2310,10 @@ subroutine set_dtbt(G, GV, CS, eta, pbce, BT_cont, gtot_est, SSH_add) ! (See Hallberg, J Comp Phys 1997 for a discussion.) real, dimension(SZIBS_(G),SZJ_(G)) :: & Datu ! Basin depth at u-velocity grid points times the y-grid - ! spacing, in m2. + ! spacing, in H m. real, dimension(SZI_(G),SZJBS_(G)) :: & Datv ! Basin depth at v-velocity grid points times the x-grid - ! spacing, in m2. + ! spacing, in H m. real :: det_de ! The partial derivative due to self-attraction and loading ! of the reference geopotential with the sea surface height. ! This is typically ~0.09 or less. @@ -2421,16 +2427,22 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! in determining the transport. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points, + !! in H m. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points, + !! in H m. type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used !! for a dynamic estimate of the face areas at !! u-points. type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used !! for a dynamic estimate of the face areas at !! v-points. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0 + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: uhbt0 !< A correction to the zonal transport so that + !! the barotropic functions agree with the sum + !! of the layer transpotts, in H m2 s-1. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vhbt0 !< A correction to the meridional transport so that + !! the barotropic functions agree with the sum + !! of the layer transpotts, in H m2 s-1. ! Local variables real :: vel_prev ! The previous velocity in m s-1. @@ -2475,23 +2487,17 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, grad(I-1,J-1) = (ubt(I-1,j) - ubt(I-1,j-1)) * G%mask2dBu(I-1,J-1) dhdt = ubt_old(I-1,j)-ubt(I-1,j) !old-new dhdx = ubt(I-1,j)-ubt(I-2,j) !in new time backward sasha for I-1 -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - if (dhdt*(grad(I-1,J) + grad(I-1,J-1)) > 0.0) then - dhdy = grad(I-1,J-1) - elseif (dhdt*(grad(I-1,J) + grad(I-1,J-1)) == 0.0) then - dhdy = 0.0 - else - dhdy = grad(I-1,J) - endif -! endif + if (dhdt*(grad(I-1,J) + grad(I-1,J-1)) > 0.0) then + dhdy = grad(I-1,J-1) + elseif (dhdt*(grad(I-1,J) + grad(I-1,J-1)) == 0.0) then + dhdy = 0.0 + else + dhdy = grad(I-1,J) + endif if (dhdt*dhdx < 0.0) dhdt = 0.0 Cx = min(dhdt*dhdx,rx_max) ! default to normal flow only -! Cy = 0 - cff = max(dhdx*dhdx, eps) -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff, max(dhdt*dhdy, -cff)) -! endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cy = min(cff, max(dhdt*dhdy, -cff)) ubt(I,j) = ((cff*ubt_old(I,j) + Cx*ubt(I-1,j)) - & (max(Cy,0.0)*grad(I,J-1) + min(Cy,0.0)*grad(I,J))) / (cff + Cx) vel_trans = ubt(I,j) @@ -2519,23 +2525,17 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, grad(I+1,J-1) = (ubt(I+1,j) - ubt(I+1,j-1)) * G%mask2dBu(I+1,J-1) dhdt = ubt_old(I+1,j)-ubt(I+1,j) !old-new dhdx = ubt(I+1,j)-ubt(I+2,j) !in new time backward sasha for I+1 -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - if (dhdt*(grad(I+1,J) + grad(I+1,J-1)) > 0.0) then - dhdy = grad(I+1,J-1) - elseif (dhdt*(grad(I+1,J) + grad(I+1,J-1)) == 0.0) then - dhdy = 0.0 - else - dhdy = grad(I+1,J) - endif -! endif + if (dhdt*(grad(I+1,J) + grad(I+1,J-1)) > 0.0) then + dhdy = grad(I+1,J-1) + elseif (dhdt*(grad(I+1,J) + grad(I+1,J-1)) == 0.0) then + dhdy = 0.0 + else + dhdy = grad(I+1,J) + endif if (dhdt*dhdx < 0.0) dhdt = 0.0 Cx = min(dhdt*dhdx,rx_max) ! default to normal flow only -! Cy = 0 - cff = max(dhdx*dhdx, eps) -! if (OBC%segment(OBC%segnum_u(I,j))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) -! endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cy = min(cff,max(dhdt*dhdy,-cff)) ubt(I,j) = ((cff*ubt_old(I,j) + Cx*ubt(I+1,j)) - & (max(Cy,0.0)*grad(I,J-1) + min(Cy,0.0)*grad(I,J))) / (cff + Cx) ! vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) @@ -2584,23 +2584,17 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, grad(I-1,J-1) = (vbt(i,J-1) - vbt(i-1,J-1)) * G%mask2dBu(I-1,J-1) dhdt = vbt_old(i,J-1)-vbt(i,J-1) !old-new dhdy = vbt(i,J-1)-vbt(i,J-2) !in new time backward sasha for J-1 -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - if (dhdt*(grad(I,J-1) + grad(I-1,J-1)) > 0.0) then - dhdx = grad(I-1,J-1) - elseif (dhdt*(grad(I,J-1) + grad(I-1,J-1)) == 0.0) then - dhdx = 0.0 - else - dhdx = grad(I,J-1) - endif -! endif + if (dhdt*(grad(I,J-1) + grad(I-1,J-1)) > 0.0) then + dhdx = grad(I-1,J-1) + elseif (dhdt*(grad(I,J-1) + grad(I-1,J-1)) == 0.0) then + dhdx = 0.0 + else + dhdx = grad(I,J-1) + endif if (dhdt*dhdy < 0.0) dhdt = 0.0 Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = min(cff,max(dhdt*dhdx,-cff)) vbt(i,J) = ((cff*vbt_old(i,J) + Cy*vbt(i,J-1)) - & (max(Cx,0.0)*grad(I-1,J) + min(Cx,0.0)*grad(I,J))) / (cff + Cy) ! vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) @@ -2629,23 +2623,17 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, grad(I-1,J+1) = (vbt(i,J+1) - vbt(i-1,J+1)) * G%mask2dBu(I-1,J+1) dhdt = vbt_old(i,J+1)-vbt(i,J+1) !old-new dhdy = vbt(i,J+1)-vbt(i,J+2) !in new time backward sasha for J+1 -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - if (dhdt*(grad(I,J+1) + grad(I-1,J+1)) > 0.0) then - dhdx = grad(I-1,J+1) - elseif (dhdt*(grad(I,J+1) + grad(I-1,J+1)) == 0.0) then - dhdx = 0.0 - else - dhdx = grad(I,J+1) - endif -! endif + if (dhdt*(grad(I,J+1) + grad(I-1,J+1)) > 0.0) then + dhdx = grad(I-1,J+1) + elseif (dhdt*(grad(I,J+1) + grad(I-1,J+1)) == 0.0) then + dhdx = 0.0 + else + dhdx = grad(I,J+1) + endif if (dhdt*dhdy < 0.0) dhdt = 0.0 Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (OBC%segment(OBC%segnum_v(i,J))%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = min(cff,max(dhdt*dhdx,-cff)) vbt(i,J) = ((cff*vbt_old(i,J) + Cy*vbt(i,J+1)) - & (max(Cx,0.0)*grad(I-1,J) + min(Cx,0.0)*grad(I,J))) / (cff + Cy) ! vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) @@ -2687,8 +2675,10 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, MS, halo, use_BT_co integer, intent(in) :: halo !< The extra halo size to use here. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. - real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points. - real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at u points. + real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: Datu !< A fixed estimate of the face areas at u points, + !! in H m. + real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: Datv !< A fixed estimate of the face areas at v points, + !! in H m. type(local_BT_cont_u_type), dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: BTCL_u !< Structure of information used !! for a dynamic estimate of the face areas at !! u-points. @@ -2877,22 +2867,25 @@ end subroutine destroy_BT_OBC !! that will drive the barotropic estimate of the free surface height toward the !! baroclinic estimate. subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). - type(barotropic_CS), pointer :: CS !< The control structure returned by a previous - !! call to barotropic_init. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: h_u !< The specified thicknesses at u-points, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: h_v !< The specified thicknesses at v-points, - !! in m or kg m-2. - logical, intent(in), optional :: may_use_default !< An optional logical argument - !! to indicate that the default velocity point - !! thickesses may be used for this particular - !! calculation, even though the setting of - !! CS%hvel_scheme would usually require that h_u - !! and h_v be passed in. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundary control structure. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + type(barotropic_CS), pointer :: CS !< The control structure returned by a previous + !! call to barotropic_init. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: h_u !< The specified thicknesses at u-points, + !! in m or kg m-2. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: h_v !< The specified thicknesses at v-points, + !! in m or kg m-2. + logical, optional, intent(in) :: may_use_default !< An optional logical argument + !! to indicate that the default velocity point + !! thickesses may be used for this particular + !! calculation, even though the setting of + !! CS%hvel_scheme would usually require that h_u + !! and h_v be passed in. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundary control structure. ! Local variables ! All of these variables are in the same units as h - usually m or kg m-2. @@ -3148,7 +3141,10 @@ end subroutine btcalc !> The function find_uhbt determines the zonal transport for a given velocity. function find_uhbt(u, BTC) result(uhbt) real, intent(in) :: u !< The local zonal velocity, in m s-1 - type(local_BT_cont_u_type), intent(in) :: BTC + type(local_BT_cont_u_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. + real :: uhbt !< The result if (u == 0.0) then @@ -3259,7 +3255,9 @@ end function uhbt_to_ubt !> The function find_vhbt determines the meridional transport for a given velocity. function find_vhbt(v, BTC) result(vhbt) real, intent(in) :: v !< The local meridional velocity, in m s-1 - type(local_BT_cont_v_type), intent(in) :: BTC + type(local_BT_cont_v_type), intent(in) :: BTC !< A structure containing various fields that + !! allow the barotropic transports to be calculated consistently + !! with the layers' continuity equations. real :: vhbt !< The result if (v == 0.0) then @@ -3592,15 +3590,18 @@ end subroutine adjust_local_BT_cont_types !> This subroutine uses the BTCL types to find typical or maximum face !! areas, which can then be used for finding wave speeds, etc. subroutine BT_cont_to_face_areas(BT_cont, Datu, Datv, G, MS, halo, maximize) - type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the - !! barotropic solver. - type(memory_size_type), intent(in) :: MS !< A type that describes the memory - !! sizes of the argument arrays. - real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), intent(out) :: Datu - real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), intent(out) :: Datv - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, optional, intent(in) :: halo !< The extra halo size to use here. - logical, optional, intent(in) :: maximize + type(BT_cont_type), intent(inout) :: BT_cont !< The BT_cont_type input to the + !! barotropic solver. + type(memory_size_type), intent(in) :: MS !< A type that describes the memory + !! sizes of the argument arrays. + real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), & + intent(out) :: Datu !< The effective zonal face area, in H m. + real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), & + intent(out) :: Datv !< The effective meridional face area, in H m. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + integer, optional, intent(in) :: halo !< The extra halo size to use here. + logical, optional, intent(in) :: maximize !< If present and true, find the + !! maximum face area for any velocity. ! Local variables logical :: find_max @@ -3629,8 +3630,9 @@ subroutine BT_cont_to_face_areas(BT_cont, Datu, Datv, G, MS, halo, maximize) end subroutine BT_cont_to_face_areas +!> Swap the values of two real variables subroutine swap(a,b) - real, intent(inout) :: a, b + real, intent(inout) :: a, b !< The varaibles to be swapped. real :: tmp tmp = a ; a = b ; b = tmp end subroutine swap @@ -3638,24 +3640,21 @@ end subroutine swap !> This subroutine determines the open face areas of cells for calculating !! the barotropic transport. subroutine find_face_areas(Datu, Datv, G, GV, CS, MS, eta, halo, add_max) - type(memory_size_type), intent(in) :: MS -! (in) MS - A type that describes the memory sizes of the argument arrays. - real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), intent(out) :: Datu !< The open zonal face area, - !! in H m (m2 or kg m-1). - real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), intent(out) :: Datv !< The open meridional face area, - !! in H m (m2 or kg m-1). - 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(barotropic_CS), pointer :: CS !< The control structure returned by a previous - !! call to barotropic_init. - real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), optional, intent(in) :: eta !< The barotropic free surface - !! height anomaly or column mass - !! anomaly, in H (m or kg m-2). - integer, optional, intent(in) :: halo !< The halo size to use, default = 1. - real, optional, intent(in) :: add_max !< A value to add to the maximum - !! depth (used to overestimate the - !! external wave speed) in m. - + type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the argument arrays. + real, dimension(MS%isdw-1:MS%iedw,MS%jsdw:MS%jedw), & + intent(out) :: Datu !< The open zonal face area, in H m (m2 or kg m-1). + real, dimension(MS%isdw:MS%iedw,MS%jsdw-1:MS%jedw), & + intent(out) :: Datv !< The open meridional face area, in H m (m2 or kg m-1). + 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(barotropic_CS), pointer :: CS !< The control structure returned by a previous + !! call to barotropic_init. + real, dimension(MS%isdw:MS%iedw,MS%jsdw:MS%jedw), & + optional, intent(in) :: eta !< The barotropic free surface height anomaly + !! or column mass anomaly, in H (m or kg m-2). + integer, optional, intent(in) :: halo !< The halo size to use, default = 1. + real, optional, intent(in) :: add_max !< A value to add to the maximum depth (used + !! to overestimate the external wave speed) in m. ! Local variables real :: H1, H2 ! Temporary total thicknesses, in m or kg m-2. @@ -3799,36 +3798,45 @@ end subroutine bt_mass_source !! barotropic calculation and initializes any barotropic fields that have not !! already been initialized. subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & - restart_CS, BT_cont, tides_CSp) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, intent(in), dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: u !< The zonal velocity, in m s-1. - real, intent(in), dimension(SZI_(G),SZJB_(G),SZK_(G)) :: v !< The meridional velocity, in m s-1. - real, intent(in), dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h !< Layer thicknesses, in H (usually m or kg m-2). - real, intent(in), dimension(SZI_(G),SZJ_(G)) :: eta !< Free surface height or column mass anomaly, in - !! m or kg m-2. - type(time_type), target, intent(in) :: Time !< The current model time. - 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(barotropic_CS), pointer :: CS !< A pointer to the control structure for this module - !! that is set in register_barotropic_restarts. - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. - type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the - !! effective open face areas as a function of - !! barotropic flow. - type(tidal_forcing_CS), optional, pointer :: tides_CSp !< A pointer to the control structure of the tide - !! module. + restart_CS, calc_dtbt, BT_cont, tides_CSp) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< The zonal velocity, in m s-1. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< The meridional velocity, in m s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: eta !< Free surface height or column mass anomaly, in + !! m or kg m-2. + type(time_type), target, intent(in) :: Time !< The current model time. + 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(barotropic_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set in register_barotropic_restarts. + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + logical, intent(out) :: calc_dtbt !< If true, the barotropic time step must + !! be recalculated before stepping. + type(BT_cont_type), optional, & + pointer :: BT_cont !< A structure with elements that describe the + !! effective open face areas as a function of + !! barotropic flow. + type(tidal_forcing_CS), optional, & + pointer :: tides_CSp !< A pointer to the control structure of the + !! tide module. ! This include declares and sets the variable "version". #include "version_variable.h" ! Local variables character(len=40) :: mdl = "MOM_barotropic" ! This module's name. - real :: Datu(SZIBS_(G),SZJ_(G)), Datv(SZI_(G),SZJBS_(G)) + real :: Datu(SZIBS_(G),SZJ_(G)) ! Zonal open face area in H m. + real :: Datv(SZI_(G),SZJBS_(G)) ! Meridional open face area in H m. real :: gtot_estimate ! Summing GV%g_prime gives an upper-bound estimate for pbce. real :: SSH_extra ! An estimate of how much higher SSH might get, for use ! in calculating the safe external wave speed. - real :: dtbt_input + real :: dtbt_input, dtbt_tmp real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag ! piston velocities. character(len=200) :: inputdir ! The directory in which to find input files. @@ -4065,11 +4073,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & units="m", default=min(10.0,0.05*G%max_depth)) call get_param(param_file, mdl, "DEBUG", CS%debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_BT", CS%debug_bt, & "If true, write out verbose debugging data within the \n"//& "barotropic time-stepping loop. The data volume can be \n"//& - "quite large if this is true.", default=CS%debug) + "quite large if this is true.", default=CS%debug, & + debuggingParam=.true.) CS%linearized_BT_PV = .true. call get_param(param_file, mdl, "BEBT", CS%bebt, & @@ -4080,7 +4090,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & "gravity waves) to 1 (for a backward Euler treatment). \n"//& "In practice, BEBT must be greater than about 0.05.", & units="nondim", default=0.1) - call get_param(param_file, mdl, "DTBT", CS%dtbt, & + call get_param(param_file, mdl, "DTBT", dtbt_input, & "The barotropic time step, in s. DTBT is only used with \n"//& "the split explicit time stepping. To set the time step \n"//& "automatically based the maximum stable value use 0, or \n"//& @@ -4237,13 +4247,22 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, param_file, diag, CS, & endif endif + CS%dtbt_fraction = 0.98 ; if (dtbt_input < 0.0) CS%dtbt_fraction = -dtbt_input + + dtbt_tmp = -1.0 + if (query_initialized(CS%dtbt, "DTBT", restart_CS)) dtbt_tmp = CS%dtbt + ! Estimate the maximum stable barotropic time step. - dtbt_input = CS%dtbt - CS%dtbt_fraction = 0.98 ; if (CS%dtbt < 0.0) CS%dtbt_fraction = -CS%dtbt gtot_estimate = 0.0 do k=1,G%ke ; gtot_estimate = gtot_estimate + GV%g_prime(K) ; enddo call set_dtbt(G, GV, CS, gtot_est = gtot_estimate, SSH_add = SSH_extra) - if (dtbt_input > 0.0) CS%dtbt = dtbt_input + + if (dtbt_input > 0.0) then + CS%dtbt = dtbt_input + elseif (dtbt_tmp > 0.0) then + CS%dtbt = dtbt_tmp + endif + if ((dtbt_tmp > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. call log_param(param_file, mdl, "DTBT as used", CS%dtbt) call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max) @@ -4523,6 +4542,9 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) call register_restart_field(CS%uhbt_IC, vd(2), .false., restart_CS) call register_restart_field(CS%vhbt_IC, vd(3), .false., restart_CS) + call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & + longname="Barotropic timestep", units="seconds") + end subroutine register_barotropic_restarts end module MOM_barotropic diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index f1f0ed9733..8f7685b605 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -49,8 +49,9 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, haloshift, symmet real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(in) :: vh !< Volume flux through meridional !! faces = v*h*dx, in m3 s-1. - integer, optional, intent(in) :: haloshift - logical, optional, intent(in) :: symmetric + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computationoal domain. ! This subroutine writes out chksums for the model's basic state variables. ! Arguments: mesg - A message that appears on the chksum lines. ! (in) u - Zonal velocity, in m s-1. @@ -87,8 +88,9 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, haloshift, symmetric) intent(in) :: v !< Meridional velocity, in m s-1. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). - integer, optional, intent(in) :: haloshift - logical, optional, intent(in) :: symmetric + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computationoal domain. ! This subroutine writes out chksums for the model's basic state variables. ! Arguments: mesg - A message that appears on the chksum lines. ! (in) u - Zonal velocity, in m s-1. @@ -118,7 +120,7 @@ subroutine MOM_thermo_chksum(mesg, tv, G, haloshift) type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, optional, intent(in) :: haloshift + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). ! This subroutine writes out chksums for the model's thermodynamic state ! variables. ! Arguments: mesg - A message that appears on the chksum lines. @@ -141,11 +143,12 @@ end subroutine MOM_thermo_chksum subroutine MOM_surface_chksum(mesg, sfc, G, haloshift, symmetric) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(surface), intent(inout) :: sfc !< transparent ocean surface state - !! structure shared with the calling routine; + !! structure shared with the calling routine !! data in this structure is intent out. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - integer, optional, intent(in) :: haloshift - logical, optional, intent(in) :: symmetric + integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computationoal domain. ! This subroutine writes out chksums for the model's thermodynamic state ! variables. ! Arguments: mesg - A message that appears on the chksum lines. @@ -197,14 +200,15 @@ subroutine MOM_accel_chksum(mesg, CAu, CAv, PFu, PFv, diffu, diffv, G, GV, pbce, real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: pbce !< The baroclinic pressure anomaly in each layer !! due to free surface height anomalies, in - !! m2 s-2 H-1. !! NULL. + !! m2 s-2 H-1. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: u_accel_bt !< The zonal acceleration from terms in the !! barotropic solver,in m s-2. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & optional, intent(in) :: v_accel_bt !< The meridional acceleration from terms in !! the barotropic solver,in m s-2. - logical, optional, intent(in) :: symmetric + logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric + !! computationoal domain. ! This subroutine writes out chksums for the model's accelerations. ! Arguments: mesg - A message that appears on the chksum lines. @@ -262,11 +266,9 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, allowChange, permitDimi intent(in) :: Temp !< Temperature in degree C. real, pointer, dimension(:,:,:), & intent(in) :: Salt !< Salinity, in ppt. - - logical, optional, intent(in) :: allowChange !< do not flag an error - !! if the statistics change. - logical, optional, & - intent(in) :: permitDiminishing !< do not flag error + logical, optional, intent(in) :: allowChange !< do not flag an error + !! if the statistics change. + logical, optional, intent(in) :: permitDiminishing !< do not flag error !!if the extrema are diminishing. ! This subroutine monitors statistics for the model's state variables. ! Arguments: mesg - A message that appears on the chksum lines. diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index f4c3bb6d66..121bbfbdb0 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -41,44 +41,62 @@ module MOM_continuity subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, & visc_rem_u, visc_rem_v, u_cor, v_cor, & uhbt_aux, vhbt_aux, u_cor_aux, v_cor_aux, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m/s. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m/s. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hin !< Initial layer thickness, in m or kg/m2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Final layer thickness, in m or kg/m2. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uh !< Volume flux through zonal faces = - !! u*h*dy, in m3/s. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vh !< Volume flux through meridional faces = - !! v*h*dx, in m3/s. - real, intent(in) :: dt !< Time increment, in s. - type(continuity_CS), pointer :: CS !< Control structure for mom_continuity. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt !< The vertically summed volume - !! flux through zonal faces, in m3/s. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt !< The vertically summed volume - !! flux through meridional faces, in m3/s. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: visc_rem_u !< Both the fraction of + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< Zonal velocity, in m/s. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< Meridional velocity, in m/s. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: hin !< Initial layer thickness, in m or kg/m2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Final layer thickness, in m or kg/m2. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: uh !< Volume flux through zonal faces = + !! u*h*dy, in m3/s. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: vh !< Volume flux through meridional faces = + !! v*h*dx, in m3/s. + real, intent(in) :: dt !< Time increment, in s. + type(continuity_CS), pointer :: CS !< Control structure for mom_continuity. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt !< The vertically summed volume + !! flux through zonal faces, in m3/s. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt !< The vertically summed volume + !! flux through meridional faces, in m3/s. + type(ocean_OBC_type), & + optional, pointer :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_u !< Both the fraction of !! zonal momentum that remains after a time-step of viscosity, and the fraction of a time-step's !! worth of a barotropic acceleration that a layer experiences after viscosity is applied. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: visc_rem_v !< Both the fraction of + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_v !< Both the fraction of !! meridional momentum that remains after a time-step of viscosity, and the fraction of a time-step's !! worth of a barotropic acceleration that a layer experiences after viscosity is applied. !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor !< The zonal velocities that + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor !< The zonal velocities that !! give uhbt as the depth-integrated transport, in m/s. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor !< The meridional velocities that + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor !< The meridional velocities that !! give vhbt as the depth-integrated transport, in m/s. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt_aux !< A second summed zonal + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt_aux !< A second summed zonal !! volume flux in m3/s. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt_aux !< A second summed meridional + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt_aux !< A second summed meridional !! volume flux in m3/s. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout), optional :: u_cor_aux !< The zonal velocities + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(inout) :: u_cor_aux !< The zonal velocities !! that give uhbt_aux as the depth-integrated transport, in m/s. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout), optional :: v_cor_aux !< The meridional velocities + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(inout) :: v_cor_aux !< The meridional velocities !! that give vhbt_aux as the depth-integrated transport, in m/s. - type(BT_cont_type), pointer, optional :: BT_cont !< A structure with elements + type(BT_cont_type), & + optional, pointer :: BT_cont !< A structure with elements !! that describe the effective open face areas as a function of barotropic flow. if (present(visc_rem_u) .neqv. present(visc_rem_v)) call MOM_error(FATAL, & diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 8a45c43c4f..a54d7bb01f 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -77,45 +77,59 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, CS, uhbt, vhbt, OBC, ! In the following documentation, H is used for the units of thickness (usually m or kg m-2.) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(continuity_PPM_CS), pointer :: CS !< Module's control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: hin !< Initial layer thickness, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Final layer thickness, in H. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uh !< Zonal volume flux, - !! u*h*dy, H m2 s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vh !< Meridional volume flux, - !! v*h*dx, H m2 s-1. - real, intent(in) :: dt !< Time increment in s. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt - !< The summed volume flux through zonal faces, H m2 s-1. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt - !< The summed volume flux through meridional faces, H m2 s-1. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: visc_rem_u - !< The fraction of zonal momentum originally in a layer that remains after a time-step - !! of viscosity, and the fraction of a time-step's worth of a barotropic acceleration that - !! a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: visc_rem_v - !< The fraction of meridional momentum originally in a layer that remains after a time-step - !! of viscosity, and the fraction of a time-step's worth of a barotropic acceleration that - !! a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor - !< The zonal velocities that give uhbt as the depth-integrated transport, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor - !< The meridional velocities that give vhbt as the depth-integrated transport, in m s-1. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt_aux - !< A second set of summed volume fluxes through zonal faces, in H m2 s-1. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt_aux - !< A second set of summed volume fluxes through meridional faces, in H m2 s-1. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor_aux - !< The zonal velocities that give uhbt_aux as the depth-integrated transports, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor_aux - !< The meridional velocities that give vhbt_aux as the depth-integrated transports, in m s-1. - type(BT_cont_type), pointer, optional :: BT_cont !< A structure with - !! elements that describe the effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< Zonal velocity, in m s-1. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< Meridional velocity, in m s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: hin !< Initial layer thickness, in H. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Final layer thickness, in H. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: uh !< Zonal volume flux, u*h*dy, H m2 s-1. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: vh !< Meridional volume flux, v*h*dx, H m2 s-1. + real, intent(in) :: dt !< Time increment in s. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt !< The summed volume flux through zonal faces, H m2 s-1. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt !< The summed volume flux through meridional faces, H m2 s-1. + type(ocean_OBC_type), & + optional, pointer :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_u !< The fraction of zonal momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_v !< The fraction of meridional momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor !< The zonal velocities that give uhbt as the + !! depth-integrated transport, in m s-1. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor !< The meridional velocities that give vhbt as the + !! depth-integrated transport, in m s-1. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt_aux !< A second set of summed volume fluxes + !! through zonal faces, in H m2 s-1. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt_aux !< A second set of summed volume fluxes + !! through meridional faces, in H m2 s-1. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor_aux !< The zonal velocities that give uhbt_aux + !! as the depth-integrated transports, in m s-1. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor_aux !< The meridional velocities that give + !! vhbt_aux as the depth-integrated transports, in m s-1. + type(BT_cont_type), & + optional, pointer :: BT_cont !< A structure with elements that describe + !! the effective open face areas as a function of barotropic flow. ! Local variables real :: h_min ! The minimum layer thickness, in H. h_min could be 0. @@ -207,35 +221,39 @@ end subroutine continuity_PPM !> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & visc_rem_u, u_cor, uhbt_aux, u_cor_aux, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes, in H. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uh !< Volume flux through zonal - !! faces = u*h*dy, H m2 s-1. - real, intent(in) :: dt !< Time increment in s. - type(continuity_PPM_CS), pointer :: CS !< This module's control structure. - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: visc_rem_u !< - !! The fraction of zonal momentum originally in a layer that remains after a time-step - !! of viscosity, and the fraction of a time-step's worth of a barotropic acceleration that - !! a layer experiences after viscosity is applied. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt - !< The summed volume flux through zonal faces, H m2 s-1. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: uhbt_aux - !< A second set of summed volume fluxes through zonal faces, in H m2 s-1. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor - !< The zonal velocitiess (u with a barotropic correction) - !! that give uhbt as the depth-integrated transport, m s-1. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out), optional :: u_cor_aux - !< The zonal velocities (u with a barotropic correction) - !! that give uhbt_aux as the depth-integrated transports, in m s-1. - type(BT_cont_type), pointer, optional :: BT_cont !< - !< A structure with elements that describe the effective - !! open face areas as a function of barotropic flow. + type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< Zonal velocity, in m s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_in !< Layer thickness used to calculate fluxes, in H. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: uh !< Volume flux through zonal faces = u*h*dy, H m2 s-1. + real, intent(in) :: dt !< Time increment in s. + type(continuity_PPM_CS), pointer :: CS !< This module's control structure. + type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + type(ocean_OBC_type), & + optional, pointer :: OBC !< Open boundaries control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_u !< The fraction of zonal momentum + !! originally in a layer that remains after a time-step of viscosity, + !! and the fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied. Non-dimensional + !! between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt !< The summed volume flux through zonal faces, H m2 s-1. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: uhbt_aux !< A second set of summed volume fluxes through + !! zonal faces, in H m2 s-1. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor !< The zonal velocitiess (u with a barotropic correction) + !! that give uhbt as the depth-integrated transport, m s-1. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: u_cor_aux !< The zonal velocities (u with a barotropic correction) + !! that give uhbt_aux as the depth-integrated transports, in m s-1. + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the effective + !! open face areas as a function of barotropic flow. + ! Local variables real, dimension(SZIB_(G),SZK_(G)) :: duhdu ! Partial derivative of uh with u, in H m. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_L, h_R ! Left and right face thicknesses, in H. @@ -455,7 +473,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, CS, LB, uhbt, OBC, & if (do_I(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) enddo do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then - if (abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) & + if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & + (OBC%segment(OBC%segnum_u(I,j))%specified)) & FAuI(I) = FAuI(I) + OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) / & OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) endif ; enddo ; enddo @@ -531,7 +550,7 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, j, & logical, dimension(SZIB_(G)), intent(in) :: do_I !< Which i values to work on. logical, intent(in) :: vol_CFL !< If true, rescale the !! ratio of face areas to the cell areas when estimating the CFL number. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. real :: curv_3 ! A measure of the thickness curvature over a grid length, @@ -598,20 +617,17 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, LB, vol_CFL, & !! in H. real, intent(in) :: dt !< Time increment in s. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - logical, intent(in) :: vol_CFL !< - !! If true, rescale the ratio of face areas to the cell - !! areas when estimating the CFL number. - logical, intent(in) :: marginal !< - !! If true, report the marginal face thicknesses; otherwise - !! report transport-averaged thicknesses. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in), optional :: visc_rem_u !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Non-dimensional between - !! 0 (at the bottom) and 1 (far above the bottom). - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + logical, intent(in) :: vol_CFL !< If true, rescale the ratio + !! of face areas to the cell areas when estimating the CFL number. + logical, intent(in) :: marginal !< If true, report the + !! marginal face thicknesses; otherwise report transport-averaged thicknesses. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_u !< Both the fraction of + !! the momentum originally in a layer that remains after a time-step of + !! viscosity, and the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity is applied. + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. @@ -649,7 +665,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, LB, vol_CFL, & if (marginal) then ; h_u(I,j,k) = h_marg else ; h_u(I,j,k) = h_avg ; endif - enddo; enddo ; enddo + enddo ; enddo ; enddo if (present(visc_rem_u)) then !$OMP parallel do default(shared) do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh @@ -712,7 +728,7 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & !! barotropic acceleration that a layer experiences !! after viscosity is applied. Non-dimensional between !! 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G)), intent(in), optional :: uhbt !< + real, dimension(SZIB_(G)), optional, intent(in) :: uhbt !< !! The summed volume flux through zonal faces, H m2 s-1. real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable !! value of du, in m s-1. @@ -731,12 +747,12 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & integer, intent(in) :: ieh !< End of index range. logical, dimension(SZIB_(G)), intent(in) :: do_I_in !< !! A logical flag indicating which I values to work on. - logical, intent(in), optional :: full_precision !< + logical, optional, intent(in) :: full_precision !< !! A flag indicating how carefully to iterate. The !! default is .true. (more accurate). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout), optional :: uh_3d !< + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), optional, intent(inout) :: uh_3d !< !! Volume flux through zonal faces = u*h*dy, H m2 s-1. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real, dimension(SZIB_(G),SZK_(G)) :: & uh_aux, & ! An auxiliary zonal volume flux, in H m s-1. @@ -1038,28 +1054,33 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & real, intent(in) :: dt !< Time increment in s. type(continuity_PPM_CS), pointer :: CS !< This module's control structure. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. - type(ocean_OBC_type), pointer, optional :: OBC !< + type(ocean_OBC_type), optional, pointer :: OBC !< !! This open boundary condition type specifies whether, where, !! and what open boundary conditions are used. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: visc_rem_v !< + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: visc_rem_v !< !! Both the fraction of the momentum originally in a !! layer that remains after a time-step of viscosity, !! and the fraction of a time-step's worth of a !! barotropic acceleration that a layer experiences !! after viscosity is applied. Nondimensional between !! 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt !< + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt !< !! The summed volume flux through meridional faces, H m2 s-1. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: vhbt_aux !< + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: vhbt_aux !< !! A second set of summed volume fluxes through meridional !! faces, in H m2 s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor !< + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor !< !! The meridional velocitiess (v with a barotropic correction) !! that give vhbt as the depth-integrated transport, m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out), optional :: v_cor_aux !< + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: v_cor_aux !< !! The meridional velocities (v with a barotropic correction) !! that give vhbt_aux as the depth-integrated transports, in m s-1. - type(BT_cont_type), pointer, optional :: BT_cont !< + type(BT_cont_type), optional, pointer :: BT_cont !< !! A structure with elements that describe the effective ! Local variables real, dimension(SZI_(G),SZK_(G)) :: & @@ -1279,7 +1300,8 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, CS, LB, vhbt, OBC, & if (do_I(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) enddo do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then - if (abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) & + if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & + (OBC%segment(OBC%segnum_v(i,J))%specified)) & FAvi(i) = FAvi(i) + & OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) / & OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) @@ -1360,7 +1382,7 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, J, & logical, dimension(SZI_(G)), intent(in) :: do_I !< Which i values to work on. logical, intent(in) :: vol_CFL !< If true, rescale the !! ratio of face areas to the cell areas when estimating the CFL number. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. real :: curv_3 ! A measure of the thickness curvature over a grid length, @@ -1434,14 +1456,14 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, LB, vol_CFL, & logical, intent(in) :: marginal !< !! If true, report the marginal face thicknesses; otherwise !! report transport-averaged thicknesses. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in), optional :: visc_rem_v !< + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), optional, intent(in) :: visc_rem_v !< !! Both the fraction of the momentum originally in a !! layer that remains after a time-step of viscosity, !! and the fraction of a time-step's worth of a !! barotropic acceleration that a layer experiences !! after viscosity is applied. Non-dimensional between !! 0 (at the bottom) and 1 (far above the bottom). - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real :: CFL ! The CFL number based on the local velocity and grid spacing, ND. @@ -1528,46 +1550,42 @@ end subroutine merid_face_thickness subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & dv, dv_max_CFL, dv_min_CFL, dt, G, CS, visc_rem, & j, ish, ieh, do_I_in, full_precision, vh_3d, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_L !< Left thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_R !< Right thickness in the - !! reconstruction, in H. - real, dimension(SZI_(G),SZK_(G)), intent(in) :: visc_rem !< - !! Both the fraction of the momentum originally in a - !! layer that remains after a time-step of viscosity, - !! and the fraction of a time-step's worth of a - !! barotropic acceleration that a layer experiences - !! after viscosity is applied. Non-dimensional between - !! 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G)), intent(in), optional :: vhbt !< - !! The summed volume flux through meridional faces, H m2 s-1. - real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value - !! of dv, in m s-1. - real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value - !! of dv, in m s-1. - real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< - !! The summed transport with 0 adjustment, in H m2 s-1. - real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< - !! The partial derivative of dv_err with dv at 0 adjustment, in H m. - real, dimension(SZI_(G)), intent(out) :: dv !< - !! The barotropic velocity adjustment, in m s-1. - real, intent(in) :: dt !< Time increment in s. - type(continuity_PPM_CS), pointer :: CS !< This module's control structure. - integer, intent(in) :: j !< Spatial index. - integer, intent(in) :: ish !< Start of index range. - integer, intent(in) :: ieh !< End of index range. - logical, dimension(SZI_(G)), intent(in) :: do_I_in !< - !! A logical flag indicating which I values to work on. - logical, intent(in), optional :: full_precision !< - !! full_precision - A flag indicating how carefully to iterate. The - !! default is .true. (more accurate). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout), optional :: vh_3d !< - !! Volume flux through meridional faces = v*h*dx, H m2 s-1. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< Meridional velocity, in m s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_in !< Layer thickness used to calculate fluxes, in H. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)),& + intent(in) :: h_L !< Left thickness in the reconstruction, in H. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_R !< Right thickness in the reconstruction, in H. + real, dimension(SZI_(G),SZK_(G)), & + intent(in) :: visc_rem !< Both the fraction of the momentum originally + !! in a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step's worth of a barotropic acceleration that + !! a layer experiences after viscosity is applied. Non-dimensional + !! between 0 (at the bottom) and 1 (far above the bottom). + real, dimension(SZI_(G)), & + optional, intent(in) :: vhbt !< The summed volume flux through meridional faces, H m2 s-1. + real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value of dv, in m s-1. + real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value of dv, in m s-1. + real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport with 0 adjustment, in H m2 s-1. + real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative of dv_err with + !! dv at 0 adjustment, in H m. + real, dimension(SZI_(G)), intent(out) :: dv !< The barotropic velocity adjustment, in m s-1. + real, intent(in) :: dt !< Time increment in s. + type(continuity_PPM_CS), pointer :: CS !< This module's control structure. + integer, intent(in) :: j !< Spatial index. + integer, intent(in) :: ish !< Start of index range. + integer, intent(in) :: ieh !< End of index range. + logical, dimension(SZI_(G)), & + intent(in) :: do_I_in !< A flag indicating which I values to work on. + logical, optional, intent(in) :: full_precision !< A flag indicating + !! how carefully to iterate. The default is .true. (more accurate). + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(inout) :: vh_3d !< Volume flux through + !! meridional faces = v*h*dx, H m2 s-1. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables real, dimension(SZI_(G),SZK_(G)) :: & vh_aux, & ! An auxiliary meridional volume flux, in H m s-1. @@ -1871,7 +1889,7 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ logical, optional, intent(in) :: simple_2nd !< If true, use the !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables with useful mnemonic names. real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. @@ -1930,12 +1948,12 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) ! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) endif - enddo; enddo + enddo ; enddo if (local_open_BC) then do n=1, OBC%number_of_segments segment => OBC%segment(n) - if (.not. segment%on_pe .or. segment%specified) cycle + if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_E .or. & segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB @@ -1957,13 +1975,13 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ ! Left/right values following Eq. B2 in Lin 1994, MWR (132) h_L(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) h_R(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) - enddo; enddo + enddo ; enddo endif if (local_open_BC) then do n=1, OBC%number_of_segments segment => OBC%segment(n) - if (.not. segment%on_pe .or. segment%specified) cycle + if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed @@ -2010,7 +2028,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ logical, optional, intent(in) :: simple_2nd !< If true, use the !! arithmetic mean thicknesses as the default edge values !! for a simple 2nd order scheme. - type(ocean_OBC_type), pointer, optional :: OBC !< Open boundaries control structure. + type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables with useful mnemonic names. real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. @@ -2074,7 +2092,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ if (local_open_BC) then do n=1, OBC%number_of_segments segment => OBC%segment(n) - if (.not. segment%on_pe .or. segment%specified) cycle + if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_S .or. & segment%direction == OBC_DIRECTION_N) then J=segment%HI%JsdB @@ -2100,7 +2118,7 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ if (local_open_BC) then do n=1, OBC%number_of_segments segment => OBC%segment(n) - if (.not. segment%on_pe .or. segment%specified) cycle + if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_N) then J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 9615c8bab6..9688ca2dcc 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -93,27 +93,34 @@ module MOM_dynamics_split_RK2 !! that were fed into the barotopic calculation, in m s-2. ! The following variables are only used with the split time stepping scheme. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta !< Instantaneous free surface height (in Boussinesq mode) - !! or column mass anomaly (in non-Boussinesq mode), - !! in units of H (m or kg m-2) - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_av !< layer x-velocity with vertical mean replaced by - !! time-mean barotropic velocity over a baroclinic timestep (m s-1) - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_av !< layer y-velocity with vertical mean replaced by - !! time-mean barotropic velocity over a baroclinic timestep (m s-1) - real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: h_av !< arithmetic mean of two successive layer thicknesses (m or kg m-2) - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_PF !< instantaneous SSH used in calculating PFu and PFv (meter) - real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt !< average x-volume or mass flux determined by barotropic solver - !! (m3 s-1 or kg s-1). uhbt should (roughly?) equal to vertical sum of uh. - real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt !< average y-volume or mass flux determined by barotropic solver - !! (m3 s-1 or kg s-1). vhbt should (roughly?) equal to vertical sum of vh. - real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure anomaly in each layer due - !! to free surface height anomalies. pbce has units of m2 H-1 s-2. - - real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean to the seafloor (Pa) - real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean to the seafloor (Pa) - type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the - !! effective summed open face areas as a function - !! of barotropic flow. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta !< Instantaneous free surface height (in Boussinesq + !! mode) or column mass anomaly (in non-Boussinesq + !! mode), in units of H (m or kg m-2) + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_av !< layer x-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep (m s-1) + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_av !< layer y-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep (m s-1) + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: h_av !< arithmetic mean of two successive layer + !! thicknesses (m or kg m-2) + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_PF !< instantaneous SSH used in calculating PFu and + !! PFv (meter) + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt !< average x-volume or mass flux determined by the + !! barotropic solver (m3 s-1 or kg s-1). uhbt should + !! be (roughly?) equal to vertical sum of uh. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt !< average y-volume or mass flux determined by the + !! barotropic solver (m3 s-1 or kg s-1). vhbt should + !! be (roughly?) equal to vertical sum of vh. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure + !! anomaly in each layer due to free surface height + !! anomalies. pbce has units of m2 H-1 s-2. + + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean to the seafloor (Pa) + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean to the seafloor (Pa) + type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the + !! effective summed open face areas as a function + !! of barotropic flow. ! This is to allow the previous, velocity-based coupling with between the ! baroclinic and barotropic modes. @@ -205,27 +212,39 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, & Time_local, dt, forces, p_surf_begin, p_surf_end, & uh, vh, uhtr, vhtr, eta_av, & G, GV, CS, calc_dtbt, VarMix, MEKE) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(inout) :: u !< zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(inout) :: v !< merid velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< layer thickness (m or kg/m2) - type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic type - type(vertvisc_type), intent(inout) :: visc !< vertical visc, bottom drag, and related - type(time_type), intent(in) :: Time_local !< model time at end of time step - real, intent(in) :: dt !< time step (sec) - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, dimension(:,:), pointer :: p_surf_begin !< surf pressure at start of this dynamic time step (Pa) - real, dimension(:,:), pointer :: p_surf_end !< surf pressure at end of this dynamic time step (Pa) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(inout) :: uh !< zonal volume/mass transport (m3/s or kg/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(inout) :: vh !< merid volume/mass transport (m3/s or kg/s) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< accumulatated zonal volume/mass transport since last tracer advection (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< accumulatated merid volume/mass transport since last tracer advection (m3 or kg) - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< free surface height or column mass time averaged over time step (m or kg/m2) - type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure - logical, intent(in) :: calc_dtbt !< if true, recalculate barotropic time step - type(VarMix_CS), pointer :: VarMix !< specify the spatially varying viscosities - type(MEKE_type), pointer :: MEKE !< related to mesoscale eddy kinetic energy param + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + target, intent(inout) :: u !< zonal velocity (m/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + target, intent(inout) :: v !< merid velocity (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< layer thickness (m or kg/m2) + type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic type + type(vertvisc_type), intent(inout) :: visc !< vertical visc, bottom drag, and related + type(time_type), intent(in) :: Time_local !< model time at end of time step + real, intent(in) :: dt !< time step (sec) + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< surf pressure at start of this dynamic + !! time step (Pa) + real, dimension(:,:), pointer :: p_surf_end !< surf pressure at end of this dynamic + !! time step (Pa) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + target, intent(inout) :: uh !< zonal volume/mass transport (m3/s or kg/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + target, intent(inout) :: vh !< merid volume/mass transport (m3/s or kg/s) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: uhtr !< accumulatated zonal volume/mass transport + !! since last tracer advection (m3 or kg) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(inout) :: vhtr !< accumulatated merid volume/mass transport + !! since last tracer advection (m3 or kg) + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< free surface height or column mass time + !! averaged over time step (m or kg/m2) + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + logical, intent(in) :: calc_dtbt !< if true, recalculate barotropic time step + type(VarMix_CS), pointer :: VarMix !< specify the spatially varying viscosities + type(MEKE_type), pointer :: MEKE !< related to mesoscale eddy kinetic energy param real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping. @@ -842,8 +861,10 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u 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), pointer :: restart_CS !< restart control structure - real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), target, intent(inout) :: uh !< zonal volume/mass transport (m3/s or kg/s) - real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), target, intent(inout) :: vh !< merid volume/mass transport (m3/s or kg/s) + real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume/mass transport (m3/s or kg/s) + real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume/mass transport (m3/s or kg/s) type(vardesc) :: vd character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. @@ -914,34 +935,42 @@ end subroutine register_restarts_dyn_split_RK2 subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_file, & diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, OBC, update_OBC_CSp, ALE_CSp, setVisc_CSp, & - visc, dirs, ntrunc) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< merid velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h !< layer thickness (m or kg/m2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(inout) :: uh !< zonal volume/mass transport (m3 s-1 or kg s-1) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(inout) :: vh !< merid volume/mass transport (m3 s-1 or kg s-1) - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: eta !< free surface height or column mass (m or kg m-2) - type(time_type), target, intent(in) :: Time !< current model time - type(param_file_type), intent(in) :: param_file !< parameter file for parsing - type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics - type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure - type(MOM_restart_CS), pointer :: restart_CS !< restart control structure - real, intent(in) :: dt !< time step (sec) - type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for budget analysis - type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation - type(ocean_internal_state), intent(inout) :: MIS !< "MOM6 internal state" used to pass diagnostic pointers - type(VarMix_CS), pointer :: VarMix !< points to spatially variable viscosities - type(MEKE_type), pointer :: MEKE !< points to mesoscale eddy kinetic energy fields - type(ocean_OBC_type), pointer :: OBC !< points to OBC related fields - type(update_OBC_CS), pointer :: update_OBC_CSp !< points to OBC update related fields - type(ALE_CS), pointer :: ALE_CSp !< points to ALE control structure - type(set_visc_CS), pointer :: setVisc_CSp !< points to the set_visc control structure. - type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, bottom drag, and related - type(directories), intent(in) :: dirs !< contains directory paths - integer, target, intent(inout) :: ntrunc !< A target for the variable that records the number of times - !! the velocity is truncated (this should be 0). + visc, dirs, ntrunc, calc_dtbt) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: u !< zonal velocity (m/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(inout) :: v !< merid velocity (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) , intent(inout) :: h !< layer thickness (m or kg/m2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + target, intent(inout) :: uh !< zonal volume/mass transport (m3 s-1 or kg s-1) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + target, intent(inout) :: vh !< merid volume/mass transport (m3 s-1 or kg s-1) + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: eta !< free surface height or column mass (m or kg m-2) + type(time_type), target, intent(in) :: Time !< current model time + type(param_file_type), intent(in) :: param_file !< parameter file for parsing + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), pointer :: restart_CS !< restart control structure + real, intent(in) :: dt !< time step (sec) + type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for + !! budget analysis + type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation + type(ocean_internal_state), intent(inout) :: MIS !< "MOM6 internal state" used to pass + !! diagnostic pointers + type(VarMix_CS), pointer :: VarMix !< points to spatially variable viscosities + type(MEKE_type), pointer :: MEKE !< points to mesoscale eddy kinetic energy fields + type(ocean_OBC_type), pointer :: OBC !< points to OBC related fields + type(update_OBC_CS), pointer :: update_OBC_CSp !< points to OBC update related fields + type(ALE_CS), pointer :: ALE_CSp !< points to ALE control structure + type(set_visc_CS), pointer :: setVisc_CSp !< points to the set_visc control structure. + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, bottom drag, and related + type(directories), intent(in) :: dirs !< contains directory paths + integer, target, intent(inout) :: ntrunc !< A target for the variable that records + !! the number of times the velocity is + !! truncated (this should be 0). + logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_tmp character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. @@ -994,7 +1023,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_fil "adjustment due to the change in the barotropic velocity \n"//& "in the barotropic continuity equation.", default=.true.) call get_param(param_file, mdl, "DEBUG", CS%debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) @@ -1073,7 +1103,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, param_fil do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo call barotropic_init(u, v, h, CS%eta, Time, G, GV, param_file, diag, & - CS%barotropic_CSp, restart_CS, CS%BT_cont, CS%tides_CSp) + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & + CS%tides_CSp) if (.not. query_initialized(CS%diffu,"diffu",restart_CS) .or. & .not. query_initialized(CS%diffv,"diffv",restart_CS)) & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 0eadfb130f..aa97b01915 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -68,7 +68,7 @@ module MOM_dynamics_unsplit use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories -use MOM_io, only : MOM_io_init, vardesc +use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) @@ -95,6 +95,7 @@ module MOM_dynamics_unsplit use MOM_vert_friction, only : vertvisc_limit_vel, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units +use MOM_wave_interface, only: wave_parameters_CS implicit none ; private @@ -164,48 +165,53 @@ module MOM_dynamics_unsplit subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, CS, & - VarMix, MEKE) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + VarMix, MEKE, Waves) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: u !< The zonal velocity, in m s-1. + intent(inout) :: u !< The zonal velocity, in m s-1. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: v !< The meridional velocity, in m s-1. + intent(inout) :: v !< The meridional velocity, in m s-1. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: h !< Layer thicknesses, in H. - !! (usually m or kg m-2). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables. - type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + intent(inout) :: h !< Layer thicknesses, in H. + !! (usually m or kg m-2). + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical !! viscosities, bottom drag viscosities, and related fields. - type(time_type), intent(in) :: Time_local !< The model time at the end - !! of the time step. - real, intent(in) :: dt !< The dynamics time step, in s. - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the + type(time_type), intent(in) :: Time_local !< The model time at the end + !! of the time step. + real, intent(in) :: dt !< The dynamics time step, in s. + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< A pointer (perhaps NULL) to the !! surface pressure at the beginning of this dynamic step, in Pa. - real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the + real, dimension(:,:), pointer :: p_surf_end !< A pointer (perhaps NULL) to the !! surface pressure at the end of this dynamic step, in Pa. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: uh !< The zonal volume or mass transport, - !! in m3 s-1 or kg s-1. + intent(inout) :: uh !< The zonal volume or mass transport, + !! in m3 s-1 or kg s-1. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: vh !< The meridional volume or mass - !! transport, in m3 s-1 or kg s-1. + intent(inout) :: vh !< The meridional volume or mass + !! transport, in m3 s-1 or kg s-1. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: uhtr !< he accumulated zonal volume or mass - !! transport since the last tracer advection, in m3 or kg. + intent(inout) :: uhtr !< he accumulated zonal volume or mass + !! transport since the last tracer advection, in m3 or kg. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(inout) :: vhtr !< The accumulated meridional volume or - !! mass transport since the last tracer advection, in m3 or kg. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< The time-mean free surface height or - !! column mass, in m or kg m-2. - type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by - !! initialize_dyn_unsplit. - type(VarMix_CS), pointer :: VarMix !< A pointer to a structure with fields - !! that specify the spatially variable viscosities. - type(MEKE_type), pointer :: MEKE !< A pointer to a structure containing - !! fields related to the Mesoscale Eddy Kinetic Energy. + intent(inout) :: vhtr !< The accumulated meridional volume or + !! mass transport since the last tracer advection, in m3 or kg. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: eta_av !< The time-mean free surface height or + !! column mass, in m or kg m-2. + type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by + !! initialize_dyn_unsplit. + type(VarMix_CS), pointer :: VarMix !< A pointer to a structure with fields + !! that specify the spatially variable viscosities. + type(MEKE_type), pointer :: MEKE !< A pointer to a structure containing + !! fields related to the Mesoscale Eddy Kinetic Energy. + type(wave_parameters_CS), & + optional, pointer :: Waves !< A pointer to a structure containing + !! fields related to the surface wave conditions + ! Arguments: u - The input and output zonal velocity, in m s-1. ! (inout) v - The input and output meridional velocity, in m s-1. ! (inout) h - The input and output layer thicknesses, in m or kg m-2, @@ -363,7 +369,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call vertvisc_coef(up, vp, h_av, forces, visc, dt*0.5, G, GV, & CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h_av, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & - G, GV, CS%vertvisc_CSp) + G, GV, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(up, vp, G%Domain, clock=id_clock_pass) @@ -427,7 +433,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, & CS%vertvisc_CSp, CS%OBC) call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & - G, GV, CS%vertvisc_CSp) + G, GV, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(upp, vpp, G%Domain, clock=id_clock_pass) @@ -497,7 +503,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call cpu_clock_begin(id_clock_vertvisc) call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, CS%vertvisc_CSp, CS%OBC) call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & - G, GV, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) + G, GV, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) call pass_vector(u, v, G%Domain, clock=id_clock_pass) @@ -549,7 +555,6 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS, restart_CS) ! (inout) CS - The control structure set up by initialize_dyn_unsplit. ! (inout) restart_CS - A pointer to the restart control structure. - type(vardesc) :: vd 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 @@ -682,7 +687,8 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, param_file, diag, CS, & CS%diag => diag call get_param(param_file, mdl, "DEBUG", CS%debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 1639f6d512..87759b0575 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -66,7 +66,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_error_handler, only : MOM_set_verbosity use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories -use MOM_io, only : MOM_io_init, vardesc +use MOM_io, only : MOM_io_init use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, MOM_restart_CS use MOM_time_manager, only : time_type, set_time, time_type_to_real, operator(+) @@ -499,7 +499,6 @@ subroutine register_restarts_dyn_unsplit_RK2(HI, GV, param_file, CS, restart_CS) ! (inout) CS - The control structure set up by initialize_dyn_unsplit_RK2. ! (inout) restart_CS - A pointer to the restart control structure. - type(vardesc) :: vd 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 @@ -645,7 +644,8 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, param_file, diag, CS "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) call get_param(param_file, mdl, "DEBUG", CS%debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index aa3bb15dc5..bb03370e03 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -118,6 +118,10 @@ module MOM_forcing_type !! in corrections to the sea surface height field !! that is passed back to the calling routines. !! This may point to p_surf or to p_surf_full. + logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere + !! and various types of ice needs to be accumulated, and the + !! surface pressure explicitly reset to zero at the driver level + !! when appropriate. ! tide related inputs real, pointer, dimension(:,:) :: & @@ -194,6 +198,10 @@ module MOM_forcing_type !! This may point to p_surf or to p_surf_full. net_mass_src => NULL(), & !< The net mass source to the ocean, in kg m-2 s-1. + ! iceberg related inputs + area_berg => NULL(), & !< area of ocean surface covered by icebergs (m2/m2) + mass_berg => NULL(), & !< mass of icebergs (kg/m2) + ! land ice-shelf related inputs frac_shelf_u => NULL(), & !< Fractional ice shelf coverage of u-cells, nondimensional !! from 0 to 1. This is only associated if ice shelves are @@ -203,6 +211,16 @@ module MOM_forcing_type !< enabled, and is exactly 0 away from shelves or on land. rigidity_ice_u => NULL(), & !< Depth-integrated lateral viscosity of ice rigidity_ice_v => NULL() !< shelves or sea ice at u- or v-points (m3/s) + logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere + !! and various types of ice needs to be accumulated, and the + !! surface pressure explicitly reset to zero at the driver level + !! when appropriate. + logical :: accumulate_rigidity = .false. !< If true, the rigidity due to various types of + !! ice needs to be accumulated, and the rigidity explicitly + !! reset to zero at the driver level when appropriate. + + logical :: initialized = .false. !< This indicates whether the appropriate + !! arrays have been initialized. end type mech_forcing !> Structure that defines the id handles for the forcing type @@ -309,66 +327,73 @@ module MOM_forcing_type !! This routine multiplies fluxes by dt, so that the result is an accumulation of fluxes !! over a time step. subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & - DepthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent, & + FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent, & h, T, netMassInOut, netMassOut, net_heat, net_salt, pen_SW_bnd, tv, & - aggregate_FW_forcing, nonpenSW, netmassInOut_rate,net_Heat_Rate, & + aggregate_FW, nonpenSW, netmassInOut_rate,net_Heat_Rate, & net_salt_rate, pen_sw_bnd_Rate, skip_diags) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(forcing), intent(inout) :: fluxes !< structure containing pointers to possible - !! forcing fields. NULL unused fields. - type(optics_type), pointer :: optics !< pointer to optics - integer, intent(in) :: nsw !< number of bands of penetrating SW - integer, intent(in) :: j !< j-index to work on - real, intent(in) :: dt !< time step in seconds - real, intent(in) :: DepthBeforeScalingFluxes !< min ocean depth before scale away fluxes (H) - logical, intent(in) :: useRiverHeatContent !< logical for river heat content - logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content - real, dimension(SZI_(G),SZK_(G)), intent(in) :: h !< layer thickness (in H units) - real, dimension(SZI_(G),SZK_(G)), intent(in) :: T !< layer temperatures (deg C) - real, dimension(SZI_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux - !! (if Bouss) of water in/out of ocean over - !! a time step (H units) - real, dimension(SZI_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux - !! (if Bouss) of water leaving ocean surface - !! over a time step (H units). - !! netMassOut < 0 means mass leaves ocean. - real, dimension(SZI_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a - !! time step for coupler + restoring. - !! Exclude two terms from net_heat: - !! (1) downwelling (penetrative) SW, - !! (2) evaporation heat content, - !! (since do not yet know evap temperature). - !! Units of net_heat are (K * H). - real, dimension(SZI_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated - !! over a time step (ppt * H) - real, dimension(:,:), intent(out) :: pen_SW_bnd !< penetrating SW flux, split into bands. - !! Units are (deg K * H) and array size - !! nsw x SZI_(G), where nsw=number of SW bands - !! in pen_SW_bnd. This heat flux is not part - !! of net_heat. - type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available - !! thermodynamic fields. Used to keep - !! track of the heat flux associated with net - !! mass fluxes into the ocean. - logical, intent(in) :: aggregate_FW_forcing !< For determining how to aggregate forcing. - real, dimension(SZI_(G)), optional, intent(out) :: nonpenSW !< non-downwelling SW; use in net_heat. - !! Sum over SW bands when diagnosing nonpenSW. - !! Units are (K * H). - real, dimension(SZI_(G)), optional, intent(out) :: net_Heat_rate !< Optional outputs of contributions to surface - real, dimension(SZI_(G)), optional, intent(out) :: net_salt_rate !< buoyancy flux which do not include dt - real, dimension(SZI_(G)), optional, intent(out) :: netmassInOut_rate !< and therefore are used to compute the rate. - real, dimension(:,:), optional, intent(out) :: pen_sw_bnd_rate !< Perhaps just a temporary fix. - logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating - !! diagnostics + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(forcing), intent(inout) :: fluxes !< structure containing pointers to possible + !! forcing fields. NULL unused fields. + type(optics_type), pointer :: optics !< pointer to optics + integer, intent(in) :: nsw !< number of bands of penetrating SW + integer, intent(in) :: j !< j-index to work on + real, intent(in) :: dt !< time step in seconds + real, intent(in) :: FluxRescaleDepth !< min ocean depth before scale away fluxes (H) + logical, intent(in) :: useRiverHeatContent !< logical for river heat content + logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content + real, dimension(SZI_(G),SZK_(G)), & + intent(in) :: h !< layer thickness (in H units) + real, dimension(SZI_(G),SZK_(G)), & + intent(in) :: T !< layer temperatures (deg C) + real, dimension(SZI_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water in/out of ocean over + !! a time step (H units) + real, dimension(SZI_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water leaving ocean surface + !! over a time step (H units). + !! netMassOut < 0 means mass leaves ocean. + real, dimension(SZI_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a + !! time step for coupler + restoring. + !! Exclude two terms from net_heat: + !! (1) downwelling (penetrative) SW, + !! (2) evaporation heat content, + !! (since do not yet know evap temperature). + !! Units of net_heat are (K * H). + real, dimension(SZI_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated + !! over a time step (ppt * H) + real, dimension(:,:), intent(out) :: pen_SW_bnd !< penetrating SW flux, split into bands. + !! Units are (deg K * H) and array size + !! nsw x SZI_(G), where nsw=number of SW bands + !! in pen_SW_bnd. This heat flux is not part + !! of net_heat. + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available + !! thermodynamic fields. Used to keep + !! track of the heat flux associated with net + !! mass fluxes into the ocean. + logical, intent(in) :: aggregate_FW !< For determining how to aggregate forcing. + real, dimension(SZI_(G)), & + optional, intent(out) :: nonpenSW !< non-downwelling SW; use in net_heat. + !! Sum over SW bands when diagnosing nonpenSW. + !! Units are (K * H). + real, dimension(SZI_(G)), & + optional, intent(out) :: net_Heat_rate !< Rate of net surface heating in H K s-1. + real, dimension(SZI_(G)), & + optional, intent(out) :: net_salt_rate !< Surface salt flux into the ocean in ppt H s-1. + real, dimension(SZI_(G)), & + optional, intent(out) :: netmassInOut_rate !< Rate of net mass flux into the ocean in H s-1. + real, dimension(:,:), & + optional, intent(out) :: pen_sw_bnd_rate !< Rate of penetrative shortwave heating + !! in degC H s-1. + logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating diagnostics ! local real :: htot(SZI_(G)) ! total ocean depth (m for Bouss or kg/m^2 for non-Bouss) real :: Pen_sw_tot(SZI_(G)) ! sum across all bands of Pen_SW (K * H) real :: pen_sw_tot_rate(SZI_(G)) ! Similar but sum but as a rate (no dt in calculation) real :: Ih_limit ! inverse depth at which surface fluxes start to be limited (1/H) - real :: scale ! scale scales away fluxes if depth < DepthBeforeScalingFluxes + real :: scale ! scale scales away fluxes if depth < FluxRescaleDepth real :: J_m2_to_H ! converts J/m^2 to H units (m for Bouss and kg/m^2 for non-Bouss) real :: Irho0 ! 1.0 / Rho0 real :: I_Cp ! 1.0 / C_p @@ -392,7 +417,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, if (present(pen_sw_bnd_rate)) do_PSWBR = .true. !}BGR - Ih_limit = 1.0 / DepthBeforeScalingFluxes + Ih_limit = 1.0 / FluxRescaleDepth Irho0 = 1.0 / GV%Rho0 I_Cp = 1.0 / fluxes%C_p J_m2_to_H = 1.0 / (GV%H_to_kg_m2 * fluxes%C_p) @@ -408,26 +433,26 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, "mismatch in the number of bands of shortwave radiation in MOM_forcing_type extract_fluxes.") endif - if (.not.ASSOCIATED(fluxes%sw)) call MOM_error(FATAL, & + if (.not.associated(fluxes%sw)) call MOM_error(FATAL, & "MOM_forcing_type extractFluxes1d: fluxes%sw is not associated.") - if (.not.ASSOCIATED(fluxes%lw)) call MOM_error(FATAL, & + if (.not.associated(fluxes%lw)) call MOM_error(FATAL, & "MOM_forcing_type extractFluxes1d: fluxes%lw is not associated.") - if (.not.ASSOCIATED(fluxes%latent)) call MOM_error(FATAL, & + if (.not.associated(fluxes%latent)) call MOM_error(FATAL, & "MOM_forcing_type extractFluxes1d: fluxes%latent is not associated.") - if (.not.ASSOCIATED(fluxes%sens)) call MOM_error(FATAL, & + if (.not.associated(fluxes%sens)) call MOM_error(FATAL, & "MOM_forcing_type extractFluxes1d: fluxes%sens is not associated.") - if (.not.ASSOCIATED(fluxes%evap)) call MOM_error(FATAL, & + if (.not.associated(fluxes%evap)) call MOM_error(FATAL, & "MOM_forcing_type extractFluxes1d: No evaporation defined.") - if (.not.ASSOCIATED(fluxes%vprec)) call MOM_error(FATAL, & + if (.not.associated(fluxes%vprec)) call MOM_error(FATAL, & "MOM_forcing_type extractFluxes1d: fluxes%vprec not defined.") - if ((.not.ASSOCIATED(fluxes%lprec)) .or. & - (.not.ASSOCIATED(fluxes%fprec))) call MOM_error(FATAL, & + if ((.not.associated(fluxes%lprec)) .or. & + (.not.associated(fluxes%fprec))) call MOM_error(FATAL, & "MOM_forcing_type extractFluxes1d: No precipitation defined.") do i=is,ie ; htot(i) = h(i,1) ; enddo @@ -451,9 +476,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, Pen_SW_bnd(1,i) = 0.0 endif - !BGR-Jul 5, 2017{ - !Repeats above code w/ dt=1. for legacy reason - if (do_PSWBR) then + if (do_PSWBR) then ! Repeat the above code w/ dt=1s for legacy reasons pen_sw_tot_rate(i) = 0.0 if (nsw >= 1) then do n=1,nsw @@ -464,7 +487,6 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, pen_sw_bnd_rate(1,i) = 0.0 endif endif - !}BGR ! net volume/mass of liquid and solid passing through surface boundary fluxes netMassInOut(i) = dt * (scale * ((((( fluxes%lprec(i,j) & @@ -474,9 +496,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, + fluxes%vprec(i,j) ) & + fluxes%frunoff(i,j) ) ) - !BGR-Jul 5, 2017{ - !Repeats above code w/ dt=1. for legacy reason - if (do_NMIOr) then + if (do_NMIOr) then ! Repeat the above code w/ dt=1s for legacy reasons netMassInOut_rate(i) = (scale * ((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & @@ -484,19 +504,15 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, + fluxes%vprec(i,j) ) & + fluxes%frunoff(i,j) ) ) endif - !}BGR ! smg: ! for non-Bouss, we add/remove salt mass to total ocean mass. to conserve - ! total salt mass ocean+ice, the sea ice model must lose mass when - ! salt mass is added to the ocean, which may still need to be coded. - if (.not.GV%Boussinesq .and. ASSOCIATED(fluxes%salt_flux)) then - netMassInOut(i) = netMassInOut(i) + (dt * GV%kg_m2_to_H) * (scale * fluxes%salt_flux(i,j)) - - !BGR-Jul 5, 2017{ - !Repeats above code w/ dt=1. for legacy reason - if (do_NMIOr) netMassInOut_rate(i) = netMassInOut_rate(i) + (GV%kg_m2_to_H) * (scale * fluxes%salt_flux(i,j)) - !}BGR + ! total salt mass ocean+ice, the sea ice model must lose mass when salt mass + ! is added to the ocean, which may still need to be coded. Not that the units + ! of netMassInOut are still kg_m2, so no conversion to H should occur yet. + if (.not.GV%Boussinesq .and. associated(fluxes%salt_flux)) then + netMassInOut(i) = netMassInOut(i) + dt * (scale * fluxes%salt_flux(i,j)) + if (do_NMIOr) netMassInOut_rate(i) = netMassInOut_rate(i) + (scale * fluxes%salt_flux(i,j)) endif ! net volume/mass of water leaving the ocean. @@ -506,43 +522,38 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! evap > 0 means condensating water is added into ocean. ! evap < 0 means evaporation of water from the ocean, in ! which case heat_content_evap is computed in MOM_diabatic_driver.F90 - if(fluxes%evap(i,j) < 0.0) then + if (fluxes%evap(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%evap(i,j) - ! if(ASSOCIATED(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA + ! if (associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA endif ! lprec < 0 means sea ice formation taking water from the ocean. ! smg: we should split the ice melt/formation from the lprec - if(fluxes%lprec(i,j) < 0.0) then + if (fluxes%lprec(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%lprec(i,j) endif ! vprec < 0 means virtual evaporation arising from surface salinity restoring, ! in which case heat_content_vprec is computed in MOM_diabatic_driver.F90. - if(fluxes%vprec(i,j) < 0.0) then + if (fluxes%vprec(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%vprec(i,j) endif netMassOut(i) = dt * scale * netMassOut(i) ! convert to H units (Bouss=meter or non-Bouss=kg/m^2) netMassInOut(i) = GV%kg_m2_to_H * netMassInOut(i) - !BGR-Jul 5, 2017{ - !Repeats above code w/ dt=1. for legacy reason if (do_NMIOr) netMassInOut_rate(i) = GV%kg_m2_to_H * netMassInOut_rate(i) - !}BGR netMassOut(i) = GV%kg_m2_to_H * netMassOut(i) ! surface heat fluxes from radiation and turbulent fluxes (K * H) ! (H=m for Bouss, H=kg/m2 for non-Bouss) net_heat(i) = scale * dt * J_m2_to_H * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) - !BGR-Jul 5, 2017{ !Repeats above code w/ dt=1. for legacy reason if (do_NHR) net_heat_rate(i) = scale * J_m2_to_H * & ( fluxes%sw(i,j) + ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) ) - !}BGR ! Add heat flux from surface damping (restoring) (K * H) or flux adjustments. - if (ASSOCIATED(fluxes%heat_added)) then + if (associated(fluxes%heat_added)) then net_heat(i) = net_heat(i) + (scale * (dt * J_m2_to_H)) * fluxes%heat_added(i,j) if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale * (J_m2_to_H)) * fluxes%heat_added(i,j) endif @@ -558,7 +569,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*(J_m2_to_H)) * fluxes%heat_content_lrunoff(i,j)) - & ! (GV%kg_m2_to_H * (scale)) * fluxes%lrunoff(i,j) * T(i,1) !}BGR - if (calculate_diags .and. ASSOCIATED(tv%TempxPmE)) then + if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & (I_Cp*fluxes%heat_content_lrunoff(i,j) - fluxes%lrunoff(i,j)*T(i,1)) endif @@ -575,7 +586,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*(J_m2_to_H)) * fluxes%heat_content_frunoff(i,j) - & ! (GV%kg_m2_to_H * (scale)) * fluxes%frunoff(i,j) * T(i,1) !}BGR - if (calculate_diags .and. ASSOCIATED(tv%TempxPmE)) then + if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & (I_Cp*fluxes%heat_content_frunoff(i,j) - fluxes%frunoff(i,j)*T(i,1)) endif @@ -590,7 +601,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! one layer of the upper ocean in the case of very thin layers. ! When evap, lprec, or vprec > 0, then we know their heat content here ! via settings from inside of the appropriate config_src driver files. -! if (ASSOCIATED(fluxes%heat_content_lprec)) then +! if (associated(fluxes%heat_content_lprec)) then ! net_heat(i) = net_heat(i) + scale * dt * J_m2_to_H * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) + & ! (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) + & @@ -612,10 +623,8 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! remove penetrative portion of the SW that is NOT absorbed within a ! tiny layer at the top of the ocean. net_heat(i) = net_heat(i) - Pen_SW_tot(i) - !BGR-Jul 5, 2017{ !Repeat above code for 'rate' term if (do_NHR) net_heat_rate(i) = net_heat_rate(i) - Pen_SW_tot_rate(i) - !}BGR ! diagnose non-downwelling SW if (present(nonPenSW)) then @@ -628,30 +637,29 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! Convert salt_flux from kg (salt)/(m^2 * s) to ! Boussinesq: (ppt * m) ! non-Bouss: (g/m^2) - if (ASSOCIATED(fluxes%salt_flux)) then + if (associated(fluxes%salt_flux)) then Net_salt(i) = (scale * dt * (1000.0 * fluxes%salt_flux(i,j))) * GV%kg_m2_to_H - !BGR-Jul 5, 2017{ !Repeat above code for 'rate' term if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0 * fluxes%salt_flux(i,j))) * GV%kg_m2_to_H - !}BGR endif ! Diagnostics follow... if (calculate_diags) then ! Store Net_salt for unknown reason? - if (ASSOCIATED(fluxes%salt_flux)) then + if (associated(fluxes%salt_flux)) then if (calculate_diags) fluxes%netSalt(i,j) = Net_salt(i) endif ! Initialize heat_content_massin that is diagnosed in mixedlayer_convection or ! applyBoundaryFluxes such that the meaning is as the sum of all incoming components. - if (ASSOCIATED(fluxes%heat_content_massin)) then - if (aggregate_FW_forcing) then + if (associated(fluxes%heat_content_massin)) then + if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" fluxes%heat_content_massin(i,j) = -fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / dt else ! net is "out" - fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * T(i,1) * GV%H_to_kg_m2 / dt + fluxes%heat_content_massin(i,j) = fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + T(i,1) * GV%H_to_kg_m2 / dt endif else fluxes%heat_content_massin(i,j) = 0. @@ -660,12 +668,13 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! Initialize heat_content_massout that is diagnosed in mixedlayer_convection or ! applyBoundaryFluxes such that the meaning is as the sum of all outgoing components. - if (ASSOCIATED(fluxes%heat_content_massout)) then - if (aggregate_FW_forcing) then + if (associated(fluxes%heat_content_massout)) then + if (aggregate_FW) then if (netMassInOut(i) > 0.0) then ! net is "in" fluxes%heat_content_massout(i,j) = fluxes%C_p * netMassOut(i) * T(i,1) * GV%H_to_kg_m2 / dt else ! net is "out" - fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * T(i,1) * GV%H_to_kg_m2 / dt + fluxes%heat_content_massout(i,j) = -fluxes%C_p * ( netMassInout(i) - netMassOut(i) ) * & + T(i,1) * GV%H_to_kg_m2 / dt endif else fluxes%heat_content_massout(i,j) = 0.0 @@ -679,7 +688,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! fluxes%lprec < 0 means ocean loses mass via sea ice formation. As we do not yet know ! the layer at which this mass is removed, we cannot compute it heat content. We must ! wait until MOM_diabatic_driver.F90. - if (ASSOCIATED(fluxes%heat_content_lprec)) then + if (associated(fluxes%heat_content_lprec)) then if (fluxes%lprec(i,j) > 0.0) then fluxes%heat_content_lprec(i,j) = fluxes%C_p*fluxes%lprec(i,j)*T(i,1) else @@ -690,7 +699,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! fprec SHOULD enter ocean at 0degC if atmos model does not provide fprec heat content. ! However, we need to adjust netHeat above to reflect the difference between 0decC and SST ! and until we do so fprec is treated like lprec and enters at SST. -AJA - if (ASSOCIATED(fluxes%heat_content_fprec)) then + if (associated(fluxes%heat_content_fprec)) then if (fluxes%fprec(i,j) > 0.0) then fluxes%heat_content_fprec(i,j) = fluxes%C_p*fluxes%fprec(i,j)*T(i,1) else @@ -701,7 +710,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! virtual precip associated with salinity restoring ! vprec > 0 means add water to ocean, assumed to be at SST ! vprec < 0 means remove water from ocean; set heat_content_vprec in MOM_diabatic_driver.F90 - if (ASSOCIATED(fluxes%heat_content_vprec)) then + if (associated(fluxes%heat_content_vprec)) then if (fluxes%vprec(i,j) > 0.0) then fluxes%heat_content_vprec(i,j) = fluxes%C_p*fluxes%vprec(i,j)*T(i,1) else @@ -715,7 +724,7 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! compute fluxes%heat_content_massout at the relevant point inside MOM_diabatic_driver.F90. ! fluxes%evap > 0 means ocean gains moisture via condensation. ! Condensation is assumed to drop into the ocean at the SST, just like lprec. - if (ASSOCIATED(fluxes%heat_content_cond)) then + if (associated(fluxes%heat_content_cond)) then if (fluxes%evap(i,j) > 0.0) then fluxes%heat_content_cond(i,j) = fluxes%C_p*fluxes%evap(i,j)*T(i,1) else @@ -725,14 +734,14 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! Liquid runoff enters ocean at SST if land model does not provide runoff heat content. if (.not. useRiverHeatContent) then - if (ASSOCIATED(fluxes%lrunoff) .and. ASSOCIATED(fluxes%heat_content_lrunoff)) then + if (associated(fluxes%lrunoff) .and. associated(fluxes%heat_content_lrunoff)) then fluxes%heat_content_lrunoff(i,j) = fluxes%C_p*fluxes%lrunoff(i,j)*T(i,1) endif endif ! Icebergs enter ocean at SST if land model does not provide calving heat content. if (.not. useCalvingHeatContent) then - if (ASSOCIATED(fluxes%frunoff) .and. ASSOCIATED(fluxes%heat_content_frunoff)) then + if (associated(fluxes%frunoff) .and. associated(fluxes%heat_content_frunoff)) then fluxes%heat_content_frunoff(i,j) = fluxes%C_p*fluxes%frunoff(i,j)*T(i,1) endif endif @@ -747,58 +756,59 @@ end subroutine extractFluxes1d !> 2d wrapper for 1d extract fluxes from surface fluxes type. !! This subroutine extracts fluxes from the surface fluxes type. It multiplies the !! fluxes by dt, so that the result is an accumulation of the fluxes over a time step. -subroutine extractFluxes2d(G, GV, fluxes, optics, nsw, dt, & - DepthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent, & - h, T, netMassInOut, netMassOut, net_heat, Net_salt, Pen_SW_bnd, tv, & - aggregate_FW_forcing) - - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(forcing), intent(inout) :: fluxes !< structure containing pointers to forcing. - type(optics_type), pointer :: optics !< pointer to optics - integer, intent(in) :: nsw !< number of bands of penetrating SW - real, intent(in) :: dt !< time step in seconds - real, intent(in) :: DepthBeforeScalingFluxes !< min ocean depth before scale away fluxes (H) - logical, intent(in) :: useRiverHeatContent !< logical for river heat content - logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< layer thickness (in H units) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T !< layer temperatures (deg C) - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux - !! (if Bouss) of water in/out of ocean over - !! a time step (H units) - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux - !! (if Bouss) of water leaving ocean surface - !! over a time step (H units). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a - !! time step associated with coupler + restore. - !! Exclude two terms from net_heat: - !! (1) downwelling (penetrative) SW, - !! (2) evaporation heat content, - !! (since do not yet know temperature of evap). - !! Units of net_heat are (K * H). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated - !! over a time step (ppt * H) - real, dimension(:,:,:), intent(out) :: pen_SW_bnd !< penetrating shortwave flux, split into bands. - !! Units (deg K * H) & array size nsw x SZI_(G), - !! where nsw=number of SW bands in pen_SW_bnd. - !! This heat flux is not in net_heat. - type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available - !! thermodynamic fields. Here it is used to keep - !! track of the heat flux associated with net - !! mass fluxes into the ocean. - logical, intent(in) :: aggregate_FW_forcing !< For determining how to aggregate the forcing. - +subroutine extractFluxes2d(G, GV, fluxes, optics, nsw, dt, FluxRescaleDepth, & + useRiverHeatContent, useCalvingHeatContent, h, T, & + netMassInOut, netMassOut, net_heat, Net_salt, Pen_SW_bnd, tv, & + aggregate_FW) + + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(forcing), intent(inout) :: fluxes !< structure containing pointers to forcing. + type(optics_type), pointer :: optics !< pointer to optics + integer, intent(in) :: nsw !< number of bands of penetrating SW + real, intent(in) :: dt !< time step in seconds + real, intent(in) :: FluxRescaleDepth !< min ocean depth before scale away fluxes (H) + logical, intent(in) :: useRiverHeatContent !< logical for river heat content + logical, intent(in) :: useCalvingHeatContent !< logical for calving heat content + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< layer thickness (in H units) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: T !< layer temperatures (deg C) + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassInOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water in/out of ocean over + !! a time step (H units) + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: netMassOut !< net mass flux (non-Bouss) or volume flux + !! (if Bouss) of water leaving ocean surface + !! over a time step (H units). + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_heat !< net heat at the surface accumulated over a + !! time step associated with coupler + restore. + !! Exclude two terms from net_heat: + !! (1) downwelling (penetrative) SW, + !! (2) evaporation heat content, + !! (since do not yet know temperature of evap). + !! Units of net_heat are (K * H). + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: net_salt !< surface salt flux into the ocean accumulated + !! over a time step (ppt * H) + real, dimension(:,:,:), intent(out) :: pen_SW_bnd !< penetrating shortwave flux, split into bands. + !! Units (deg K * H) & array size nsw x SZI_(G), + !! where nsw=number of SW bands in pen_SW_bnd. + !! This heat flux is not in net_heat. + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to available + !! thermodynamic fields. Here it is used to keep + !! track of the heat flux associated with net + !! mass fluxes into the ocean. + logical, intent(in) :: aggregate_FW !< For determining how to aggregate the forcing. integer :: j -!$OMP parallel do default(none) shared(G, GV, fluxes, optics, nsw,dt,DepthBeforeScalingFluxes, & +!$OMP parallel do default(none) shared(G, GV, fluxes, optics, nsw,dt,FluxRescaleDepth, & !$OMP useRiverHeatContent, useCalvingHeatContent, & !$OMP h,T,netMassInOut,netMassOut,Net_heat,Net_salt,Pen_SW_bnd,tv, & -!$OMP aggregate_FW_forcing) +!$OMP aggregate_FW) do j=G%jsc, G%jec call extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, & - DepthBeforeScalingFluxes, useRiverHeatContent, useCalvingHeatContent,& + FluxRescaleDepth, useRiverHeatContent, useCalvingHeatContent,& h(:,j,:), T(:,j,:), netMassInOut(:,j), netMassOut(:,j), & - net_heat(:,j), net_salt(:,j), pen_SW_bnd(:,:,j), tv, aggregate_FW_forcing) + net_heat(:,j), net_salt(:,j), pen_SW_bnd(:,:,j), tv, aggregate_FW) enddo end subroutine extractFluxes2d @@ -822,8 +832,8 @@ subroutine calculateBuoyancyFlux1d(G, GV, fluxes, optics, h, Temp, Salt, tv, j, real, dimension(SZI_(G),SZK_(G)+1), intent(inout) :: buoyancyFlux !< buoyancy flux (m^2/s^3) real, dimension(SZI_(G)), intent(inout) :: netHeatMinusSW !< surf Heat flux (K H/s) real, dimension(SZI_(G)), intent(inout) :: netSalt !< surf salt flux (ppt H/s) - logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating - !! diagnostics inside extractFluxes1d() + logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating + !! diagnostics inside extractFluxes1d() ! local variables integer :: nsw, start, npts, k real, parameter :: dt = 1. ! to return a rate from extractFluxes1d @@ -910,7 +920,7 @@ subroutine calculateBuoyancyFlux2d(G, GV, fluxes, optics, h, Temp, Salt, tv, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: buoyancyFlux !< buoy flux (m^2/s^3) real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: netHeatMinusSW !< surf temp flux (K H) real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: netSalt !< surf salt flux (ppt H) - logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating + logical, optional, intent(in) :: skip_diags !< If present and true, skip calculating !! diagnostics inside extractFluxes1d() ! local variables real, dimension( SZI_(G) ) :: netT ! net temperature flux (K m/s) @@ -1532,7 +1542,7 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use handles%id_total_net_heat_surface = register_scalar_field('ocean_model', & 'total_net_heat_surface', Time, diag, & - long_name='Area integrated surface heat flux from SW+LW+lat+sens+mass+frazil+restore or flux adjustments', & + long_name='Area integrated surface heat flux from SW+LW+lat+sens+mass+frazil+restore or flux adjustments', & units='W', & cmor_field_name='total_hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_integrated', & @@ -1619,7 +1629,7 @@ subroutine register_forcing_type_diags(Time, diag, use_temperature, handles, use 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 or flux adjustments', & + long_name='Area averaged surface heat flux from SW+LW+lat+sens+mass+frazil+restore or flux adjustments', & units='W m-2', & cmor_field_name='ave_hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_averaged', & @@ -1736,12 +1746,14 @@ end subroutine register_forcing_type_diags !> Accumulate the forcing over time steps subroutine forcing_accumulate(flux_tmp, forces, fluxes, dt, G, wt2) - type(forcing), intent(in) :: flux_tmp + type(forcing), intent(in) :: flux_tmp !< A temporary structure with current + !!thermodynamic forcing fields type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes + type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged + !! thermodynamic forcing fields real, intent(in) :: dt !< The elapsed time since the last call to this subroutine, in s type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 + real, intent(out) :: wt2 !< The relative weight of the new fluxes ! This subroutine copies mechancal forcing from flux_tmp to fluxes and ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, @@ -1861,37 +1873,43 @@ end subroutine forcing_accumulate !> This subroutine copies the computational domains of common forcing fields !! from a mech_forcing type to a (thermodynamic) forcing type. -subroutine copy_common_forcing_fields(forces, fluxes, G) +subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields type(ocean_grid_type), intent(in) :: G !< grid type + logical, optional, intent(in) :: skip_pres !< If present and true, do not copy pressure fields. real :: taux2, tauy2 ! Squared wind stress components, in Pa^2. + logical :: do_pres integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + do_pres = .true. ; if (present(skip_pres)) do_pres = .not.skip_pres + if (associated(forces%ustar) .and. associated(fluxes%ustar)) then do j=js,je ; do i=is,ie fluxes%ustar(i,j) = forces%ustar(i,j) enddo ; enddo endif - if (associated(forces%p_surf) .and. associated(fluxes%p_surf)) then - do j=js,je ; do i=is,ie - fluxes%p_surf(i,j) = forces%p_surf(i,j) - enddo ; enddo - endif + if (do_pres) then + if (associated(forces%p_surf) .and. associated(fluxes%p_surf)) then + do j=js,je ; do i=is,ie + fluxes%p_surf(i,j) = forces%p_surf(i,j) + enddo ; enddo + endif - if (associated(forces%p_surf_full) .and. associated(fluxes%p_surf_full)) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) - enddo ; enddo - endif + if (associated(forces%p_surf_full) .and. associated(fluxes%p_surf_full)) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + enddo ; enddo + endif - if (associated(forces%p_surf_SSH, forces%p_surf_full)) then - fluxes%p_surf_SSH => fluxes%p_surf_full - elseif (associated(forces%p_surf_SSH, forces%p_surf)) then - fluxes%p_surf_SSH => fluxes%p_surf + if (associated(forces%p_surf_SSH, forces%p_surf_full)) then + fluxes%p_surf_SSH => fluxes%p_surf_full + elseif (associated(forces%p_surf_SSH, forces%p_surf)) then + fluxes%p_surf_SSH => fluxes%p_surf + endif endif end subroutine copy_common_forcing_fields @@ -2001,11 +2019,11 @@ subroutine mech_forcing_diags(forces, fluxes, dt, G, diag, handles) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec if (query_averaging_enabled(diag)) then - if ((handles%id_taux > 0) .and. ASSOCIATED(forces%taux)) & + if ((handles%id_taux > 0) .and. associated(forces%taux)) & call post_data(handles%id_taux, forces%taux, diag) - if ((handles%id_tauy > 0) .and. ASSOCIATED(forces%tauy)) & + if ((handles%id_tauy > 0) .and. associated(forces%tauy)) & call post_data(handles%id_tauy, forces%tauy, diag) - if ((handles%id_ustar > 0) .and. ASSOCIATED(fluxes%ustar)) & + if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & call post_data(handles%id_ustar, fluxes%ustar, diag) if (handles%id_ustar_berg > 0) & call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) @@ -2027,7 +2045,7 @@ end subroutine mech_forcing_diags !> Offer buoyancy forcing fields for diagnostics for those !! fields registered as part of register_forcing_type_diags. subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) - type(forcing), intent(in) :: fluxes !< flux type + type(forcing), intent(in) :: fluxes !< A structure containing thermodynamic forcing fields type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, intent(in) :: dt !< time step @@ -2058,70 +2076,70 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_prcme > 0 .or. handles%id_total_prcme > 0 .or. handles%id_prcme_ga > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (ASSOCIATED(fluxes%lprec)) res(i,j) = res(i,j)+fluxes%lprec(i,j) - if (ASSOCIATED(fluxes%fprec)) res(i,j) = res(i,j)+fluxes%fprec(i,j) + if (associated(fluxes%lprec)) res(i,j) = res(i,j)+fluxes%lprec(i,j) + if (associated(fluxes%fprec)) res(i,j) = res(i,j)+fluxes%fprec(i,j) ! fluxes%cond is not needed because it is derived from %evap > 0 - if (ASSOCIATED(fluxes%evap)) res(i,j) = res(i,j)+fluxes%evap(i,j) - if (ASSOCIATED(fluxes%lrunoff)) res(i,j) = res(i,j)+fluxes%lrunoff(i,j) - if (ASSOCIATED(fluxes%frunoff)) res(i,j) = res(i,j)+fluxes%frunoff(i,j) - if (ASSOCIATED(fluxes%vprec)) res(i,j) = res(i,j)+fluxes%vprec(i,j) + if (associated(fluxes%evap)) res(i,j) = res(i,j)+fluxes%evap(i,j) + if (associated(fluxes%lrunoff)) res(i,j) = res(i,j)+fluxes%lrunoff(i,j) + if (associated(fluxes%frunoff)) res(i,j) = res(i,j)+fluxes%frunoff(i,j) + if (associated(fluxes%vprec)) res(i,j) = res(i,j)+fluxes%vprec(i,j) enddo ; enddo call post_data(handles%id_prcme, res, diag) - if(handles%id_total_prcme > 0) then + if (handles%id_total_prcme > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_prcme, total_transport, diag) endif - if(handles%id_prcme_ga > 0) then + if (handles%id_prcme_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_prcme_ga, ave_flux, diag) endif endif - if(handles%id_net_massout > 0 .or. handles%id_total_net_massout > 0) then + if (handles%id_net_massout > 0 .or. handles%id_total_net_massout > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if(fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) - if(fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) - if(fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) enddo ; enddo call post_data(handles%id_net_massout, res, diag) - if(handles%id_total_net_massout > 0) then + if (handles%id_total_net_massout > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_massout, total_transport, diag) endif endif - if(handles%id_massout_flux > 0) call post_data(handles%id_massout_flux,fluxes%netMassOut,diag) + if (handles%id_massout_flux > 0) call post_data(handles%id_massout_flux,fluxes%netMassOut,diag) - if(handles%id_net_massin > 0 .or. handles%id_total_net_massin > 0) then + if (handles%id_net_massin > 0 .or. handles%id_total_net_massin > 0) then do j=js,je ; do i=is,ie res(i,j) = fluxes%fprec(i,j) + fluxes%lrunoff(i,j) + fluxes%frunoff(i,j) - if(fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) - if(fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) ! fluxes%cond is not needed because it is derived from %evap > 0 - if(fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) enddo ; enddo call post_data(handles%id_net_massin, res, diag) - if(handles%id_total_net_massin > 0) then + if (handles%id_total_net_massin > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_massin, total_transport, diag) endif endif - if(handles%id_massin_flux > 0) call post_data(handles%id_massin_flux,fluxes%netMassIn,diag) + if (handles%id_massin_flux > 0) call post_data(handles%id_massin_flux,fluxes%netMassIn,diag) - if ((handles%id_evap > 0) .and. ASSOCIATED(fluxes%evap)) & + if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & call post_data(handles%id_evap, fluxes%evap, diag) - if ((handles%id_total_evap > 0) .and. ASSOCIATED(fluxes%evap)) then + if ((handles%id_total_evap > 0) .and. associated(fluxes%evap)) then total_transport = global_area_integral(fluxes%evap,G) call post_data(handles%id_total_evap, total_transport, diag) endif - if ((handles%id_evap_ga > 0) .and. ASSOCIATED(fluxes%evap)) then + if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then ave_flux = global_area_mean(fluxes%evap,G) call post_data(handles%id_evap_ga, ave_flux, diag) endif - if (ASSOCIATED(fluxes%lprec) .and. ASSOCIATED(fluxes%fprec)) then + if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie res(i,j) = fluxes%lprec(i,j) + fluxes%fprec(i,j) enddo ; enddo @@ -2136,7 +2154,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) endif endif - if (ASSOCIATED(fluxes%lprec)) then + if (associated(fluxes%lprec)) then if (handles%id_lprec > 0) call post_data(handles%id_lprec, fluxes%lprec, diag) if (handles%id_total_lprec > 0) then total_transport = global_area_integral(fluxes%lprec,G) @@ -2148,7 +2166,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) endif endif - if (ASSOCIATED(fluxes%fprec)) then + if (associated(fluxes%fprec)) then if (handles%id_fprec > 0) call post_data(handles%id_fprec, fluxes%fprec, diag) if (handles%id_total_fprec > 0) then total_transport = global_area_integral(fluxes%fprec,G) @@ -2160,7 +2178,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) endif endif - if (ASSOCIATED(fluxes%vprec)) then + if (associated(fluxes%vprec)) then if (handles%id_vprec > 0) call post_data(handles%id_vprec, fluxes%vprec, diag) if (handles%id_total_vprec > 0) then total_transport = global_area_integral(fluxes%vprec,G) @@ -2172,7 +2190,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) endif endif - if (ASSOCIATED(fluxes%lrunoff)) then + if (associated(fluxes%lrunoff)) then if (handles%id_lrunoff > 0) call post_data(handles%id_lrunoff, fluxes%lrunoff, diag) if (handles%id_total_lrunoff > 0) then total_transport = global_area_integral(fluxes%lrunoff,G) @@ -2180,7 +2198,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) endif endif - if (ASSOCIATED(fluxes%frunoff)) then + if (associated(fluxes%frunoff)) then if (handles%id_frunoff > 0) call post_data(handles%id_frunoff, fluxes%frunoff, diag) if (handles%id_total_frunoff > 0) then total_transport = global_area_integral(fluxes%frunoff,G) @@ -2190,109 +2208,111 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) ! post diagnostics for boundary heat fluxes ==================================== - if ((handles%id_heat_content_lrunoff > 0) .and. ASSOCIATED(fluxes%heat_content_lrunoff)) & + if ((handles%id_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) & call post_data(handles%id_heat_content_lrunoff, fluxes%heat_content_lrunoff, diag) - if ((handles%id_total_heat_content_lrunoff > 0) .and. ASSOCIATED(fluxes%heat_content_lrunoff)) then + if ((handles%id_total_heat_content_lrunoff > 0) .and. associated(fluxes%heat_content_lrunoff)) then total_transport = global_area_integral(fluxes%heat_content_lrunoff,G) call post_data(handles%id_total_heat_content_lrunoff, total_transport, diag) endif - if ((handles%id_heat_content_frunoff > 0) .and. ASSOCIATED(fluxes%heat_content_frunoff)) & + if ((handles%id_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) & call post_data(handles%id_heat_content_frunoff, fluxes%heat_content_frunoff, diag) - if ((handles%id_total_heat_content_frunoff > 0) .and. ASSOCIATED(fluxes%heat_content_frunoff)) then + if ((handles%id_total_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) then total_transport = global_area_integral(fluxes%heat_content_frunoff,G) call post_data(handles%id_total_heat_content_frunoff, total_transport, diag) endif - if ((handles%id_heat_content_lprec > 0) .and. ASSOCIATED(fluxes%heat_content_lprec)) & + if ((handles%id_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) & call post_data(handles%id_heat_content_lprec, fluxes%heat_content_lprec, diag) - if ((handles%id_total_heat_content_lprec > 0) .and. ASSOCIATED(fluxes%heat_content_lprec)) then + if ((handles%id_total_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) then total_transport = global_area_integral(fluxes%heat_content_lprec,G) call post_data(handles%id_total_heat_content_lprec, total_transport, diag) endif - if ((handles%id_heat_content_fprec > 0) .and. ASSOCIATED(fluxes%heat_content_fprec)) & + if ((handles%id_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) & call post_data(handles%id_heat_content_fprec, fluxes%heat_content_fprec, diag) - if ((handles%id_total_heat_content_fprec > 0) .and. ASSOCIATED(fluxes%heat_content_fprec)) then + if ((handles%id_total_heat_content_fprec > 0) .and. associated(fluxes%heat_content_fprec)) then total_transport = global_area_integral(fluxes%heat_content_fprec,G) call post_data(handles%id_total_heat_content_fprec, total_transport, diag) endif - if ((handles%id_heat_content_vprec > 0) .and. ASSOCIATED(fluxes%heat_content_vprec)) & + if ((handles%id_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) & call post_data(handles%id_heat_content_vprec, fluxes%heat_content_vprec, diag) - if ((handles%id_total_heat_content_vprec > 0) .and. ASSOCIATED(fluxes%heat_content_vprec)) then + if ((handles%id_total_heat_content_vprec > 0) .and. associated(fluxes%heat_content_vprec)) then total_transport = global_area_integral(fluxes%heat_content_vprec,G) call post_data(handles%id_total_heat_content_vprec, total_transport, diag) endif - if ((handles%id_heat_content_cond > 0) .and. ASSOCIATED(fluxes%heat_content_cond)) & + if ((handles%id_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) & call post_data(handles%id_heat_content_cond, fluxes%heat_content_cond, diag) - if ((handles%id_total_heat_content_cond > 0) .and. ASSOCIATED(fluxes%heat_content_cond)) then + if ((handles%id_total_heat_content_cond > 0) .and. associated(fluxes%heat_content_cond)) then total_transport = global_area_integral(fluxes%heat_content_cond,G) call post_data(handles%id_total_heat_content_cond, total_transport, diag) endif - if ((handles%id_heat_content_massout > 0) .and. ASSOCIATED(fluxes%heat_content_massout)) & + if ((handles%id_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) & call post_data(handles%id_heat_content_massout, fluxes%heat_content_massout, diag) - if ((handles%id_total_heat_content_massout > 0) .and. ASSOCIATED(fluxes%heat_content_massout)) then + if ((handles%id_total_heat_content_massout > 0) .and. associated(fluxes%heat_content_massout)) then total_transport = global_area_integral(fluxes%heat_content_massout,G) call post_data(handles%id_total_heat_content_massout, total_transport, diag) endif - if ((handles%id_heat_content_massin > 0) .and. ASSOCIATED(fluxes%heat_content_massin)) & + if ((handles%id_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) & call post_data(handles%id_heat_content_massin, fluxes%heat_content_massin, diag) - if ((handles%id_total_heat_content_massin > 0) .and. ASSOCIATED(fluxes%heat_content_massin)) then + if ((handles%id_total_heat_content_massin > 0) .and. associated(fluxes%heat_content_massin)) then total_transport = global_area_integral(fluxes%heat_content_massin,G) call post_data(handles%id_total_heat_content_massin, total_transport, diag) endif - if (handles%id_net_heat_coupler > 0 .or. handles%id_total_net_heat_coupler > 0 .or. handles%id_net_heat_coupler_ga > 0. ) then + if (handles%id_net_heat_coupler > 0 .or. handles%id_total_net_heat_coupler > 0 .or. & + handles%id_net_heat_coupler_ga > 0. ) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (ASSOCIATED(fluxes%LW)) res(i,j) = res(i,j) + fluxes%LW(i,j) - if (ASSOCIATED(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) - if (ASSOCIATED(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) - if (ASSOCIATED(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) + if (associated(fluxes%LW)) res(i,j) = res(i,j) + fluxes%LW(i,j) + if (associated(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) + if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) + if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) enddo ; enddo call post_data(handles%id_net_heat_coupler, res, diag) - if(handles%id_total_net_heat_coupler > 0) then + if (handles%id_total_net_heat_coupler > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_heat_coupler, total_transport, diag) endif - if(handles%id_net_heat_coupler_ga > 0) then + if (handles%id_net_heat_coupler_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_net_heat_coupler_ga, ave_flux, diag) endif endif - if (handles%id_net_heat_surface > 0 .or. handles%id_total_net_heat_surface > 0 .or. handles%id_net_heat_surface_ga > 0. ) then + if (handles%id_net_heat_surface > 0 .or. handles%id_total_net_heat_surface > 0 .or. & + handles%id_net_heat_surface_ga > 0. ) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (ASSOCIATED(fluxes%LW)) res(i,j) = res(i,j) + fluxes%LW(i,j) - if (ASSOCIATED(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) - if (ASSOCIATED(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) - if (ASSOCIATED(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) - if (ASSOCIATED(sfc_state%frazil)) res(i,j) = res(i,j) + sfc_state%frazil(i,j) * I_dt - ! if (ASSOCIATED(sfc_state%TempXpme)) then + if (associated(fluxes%LW)) res(i,j) = res(i,j) + fluxes%LW(i,j) + if (associated(fluxes%latent)) res(i,j) = res(i,j) + fluxes%latent(i,j) + if (associated(fluxes%sens)) res(i,j) = res(i,j) + fluxes%sens(i,j) + if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) + if (associated(sfc_state%frazil)) res(i,j) = res(i,j) + sfc_state%frazil(i,j) * I_dt + ! if (associated(sfc_state%TempXpme)) then ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt ! else - if (ASSOCIATED(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if (ASSOCIATED(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) - if (ASSOCIATED(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if (ASSOCIATED(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if (ASSOCIATED(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) - if (ASSOCIATED(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) - if (ASSOCIATED(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) ! endif - if (ASSOCIATED(fluxes%heat_added)) res(i,j) = res(i,j) + fluxes%heat_added(i,j) + if (associated(fluxes%heat_added)) res(i,j) = res(i,j) + fluxes%heat_added(i,j) enddo ; enddo call post_data(handles%id_net_heat_surface, res, diag) - if(handles%id_total_net_heat_surface > 0) then + if (handles%id_total_net_heat_surface > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif - if(handles%id_net_heat_surface_ga > 0) then + if (handles%id_net_heat_surface_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) endif @@ -2301,20 +2321,20 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_heat_content_surfwater > 0 .or. handles%id_total_heat_content_surfwater > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - ! if (ASSOCIATED(sfc_state%TempXpme)) then + ! if (associated(sfc_state%TempXpme)) then ! res(i,j) = res(i,j) + sfc_state%TempXpme(i,j) * fluxes%C_p * I_dt ! else - if (ASSOCIATED(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if (ASSOCIATED(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) - if (ASSOCIATED(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if (ASSOCIATED(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if (ASSOCIATED(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) - if (ASSOCIATED(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) - if (ASSOCIATED(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) ! endif enddo ; enddo call post_data(handles%id_heat_content_surfwater, res, diag) - if(handles%id_total_heat_content_surfwater > 0) then + if (handles%id_total_heat_content_surfwater > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) endif @@ -2324,8 +2344,8 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_hfrunoffds > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if(ASSOCIATED(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if(ASSOCIATED(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) enddo ; enddo call post_data(handles%id_hfrunoffds, res, diag) endif @@ -2334,23 +2354,23 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_hfrainds > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if(ASSOCIATED(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if(ASSOCIATED(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if(ASSOCIATED(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) enddo ; enddo call post_data(handles%id_hfrainds, res, diag) endif - if ((handles%id_LwLatSens > 0) .and. ASSOCIATED(fluxes%lw) .and. & - ASSOCIATED(fluxes%latent) .and. ASSOCIATED(fluxes%sens)) then + if ((handles%id_LwLatSens > 0) .and. associated(fluxes%lw) .and. & + associated(fluxes%latent) .and. associated(fluxes%sens)) then 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 call post_data(handles%id_LwLatSens, res, diag) endif - if ((handles%id_total_LwLatSens > 0) .and. ASSOCIATED(fluxes%lw) .and. & - ASSOCIATED(fluxes%latent) .and. ASSOCIATED(fluxes%sens)) then + if ((handles%id_total_LwLatSens > 0) .and. associated(fluxes%lw) .and. & + associated(fluxes%latent) .and. associated(fluxes%sens)) then 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 @@ -2358,8 +2378,8 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) call post_data(handles%id_total_LwLatSens, total_transport, diag) endif - if ((handles%id_LwLatSens_ga > 0) .and. ASSOCIATED(fluxes%lw) .and. & - ASSOCIATED(fluxes%latent) .and. ASSOCIATED(fluxes%sens)) then + if ((handles%id_LwLatSens_ga > 0) .and. associated(fluxes%lw) .and. & + associated(fluxes%latent) .and. associated(fluxes%sens)) then 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 @@ -2367,91 +2387,91 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) call post_data(handles%id_LwLatSens_ga, ave_flux, diag) endif - if ((handles%id_sw > 0) .and. ASSOCIATED(fluxes%sw)) then + if ((handles%id_sw > 0) .and. associated(fluxes%sw)) then call post_data(handles%id_sw, fluxes%sw, diag) endif - if ((handles%id_sw_vis > 0) .and. ASSOCIATED(fluxes%sw_vis_dir) .and. & - ASSOCIATED(fluxes%sw_vis_dif)) then + if ((handles%id_sw_vis > 0) .and. associated(fluxes%sw_vis_dir) .and. & + associated(fluxes%sw_vis_dif)) then call post_data(handles%id_sw_vis, fluxes%sw_vis_dir+fluxes%sw_vis_dif, diag) endif - if ((handles%id_sw_nir > 0) .and. ASSOCIATED(fluxes%sw_nir_dir) .and. & - ASSOCIATED(fluxes%sw_nir_dif)) then + if ((handles%id_sw_nir > 0) .and. associated(fluxes%sw_nir_dir) .and. & + associated(fluxes%sw_nir_dif)) then call post_data(handles%id_sw_nir, fluxes%sw_nir_dir+fluxes%sw_nir_dif, diag) endif - if ((handles%id_total_sw > 0) .and. ASSOCIATED(fluxes%sw)) then + if ((handles%id_total_sw > 0) .and. associated(fluxes%sw)) then total_transport = global_area_integral(fluxes%sw,G) call post_data(handles%id_total_sw, total_transport, diag) endif - if ((handles%id_sw_ga > 0) .and. ASSOCIATED(fluxes%sw)) then + if ((handles%id_sw_ga > 0) .and. associated(fluxes%sw)) then ave_flux = global_area_mean(fluxes%sw,G) call post_data(handles%id_sw_ga, ave_flux, diag) endif - if ((handles%id_lw > 0) .and. ASSOCIATED(fluxes%lw)) then + if ((handles%id_lw > 0) .and. associated(fluxes%lw)) then call post_data(handles%id_lw, fluxes%lw, diag) endif - if ((handles%id_total_lw > 0) .and. ASSOCIATED(fluxes%lw)) then + if ((handles%id_total_lw > 0) .and. associated(fluxes%lw)) then total_transport = global_area_integral(fluxes%lw,G) call post_data(handles%id_total_lw, total_transport, diag) endif - if ((handles%id_lw_ga > 0) .and. ASSOCIATED(fluxes%lw)) then + if ((handles%id_lw_ga > 0) .and. associated(fluxes%lw)) then ave_flux = global_area_mean(fluxes%lw,G) call post_data(handles%id_lw_ga, ave_flux, diag) endif - if ((handles%id_lat > 0) .and. ASSOCIATED(fluxes%latent)) then + if ((handles%id_lat > 0) .and. associated(fluxes%latent)) then call post_data(handles%id_lat, fluxes%latent, diag) endif - if ((handles%id_total_lat > 0) .and. ASSOCIATED(fluxes%latent)) then + if ((handles%id_total_lat > 0) .and. associated(fluxes%latent)) then total_transport = global_area_integral(fluxes%latent,G) call post_data(handles%id_total_lat, total_transport, diag) endif - if ((handles%id_lat_ga > 0) .and. ASSOCIATED(fluxes%latent)) then + if ((handles%id_lat_ga > 0) .and. associated(fluxes%latent)) then ave_flux = global_area_mean(fluxes%latent,G) call post_data(handles%id_lat_ga, ave_flux, diag) endif - if ((handles%id_lat_evap > 0) .and. ASSOCIATED(fluxes%latent_evap_diag)) then + if ((handles%id_lat_evap > 0) .and. associated(fluxes%latent_evap_diag)) then call post_data(handles%id_lat_evap, fluxes%latent_evap_diag, diag) endif - if ((handles%id_total_lat_evap > 0) .and. ASSOCIATED(fluxes%latent_evap_diag)) then + if ((handles%id_total_lat_evap > 0) .and. associated(fluxes%latent_evap_diag)) then total_transport = global_area_integral(fluxes%latent_evap_diag,G) call post_data(handles%id_total_lat_evap, total_transport, diag) endif - if ((handles%id_lat_fprec > 0) .and. ASSOCIATED(fluxes%latent_fprec_diag)) then + if ((handles%id_lat_fprec > 0) .and. associated(fluxes%latent_fprec_diag)) then call post_data(handles%id_lat_fprec, fluxes%latent_fprec_diag, diag) endif - if ((handles%id_total_lat_fprec > 0) .and. ASSOCIATED(fluxes%latent_fprec_diag)) then + if ((handles%id_total_lat_fprec > 0) .and. associated(fluxes%latent_fprec_diag)) then total_transport = global_area_integral(fluxes%latent_fprec_diag,G) call post_data(handles%id_total_lat_fprec, total_transport, diag) endif - if ((handles%id_lat_frunoff > 0) .and. ASSOCIATED(fluxes%latent_frunoff_diag)) then + if ((handles%id_lat_frunoff > 0) .and. associated(fluxes%latent_frunoff_diag)) then call post_data(handles%id_lat_frunoff, fluxes%latent_frunoff_diag, diag) endif - if(handles%id_total_lat_frunoff > 0 .and. ASSOCIATED(fluxes%latent_frunoff_diag)) then + if (handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then total_transport = global_area_integral(fluxes%latent_frunoff_diag,G) call post_data(handles%id_total_lat_frunoff, total_transport, diag) endif - if ((handles%id_sens > 0) .and. ASSOCIATED(fluxes%sens)) then + if ((handles%id_sens > 0) .and. associated(fluxes%sens)) then call post_data(handles%id_sens, fluxes%sens, diag) endif - if ((handles%id_total_sens > 0) .and. ASSOCIATED(fluxes%sens)) then + if ((handles%id_total_sens > 0) .and. associated(fluxes%sens)) then total_transport = global_area_integral(fluxes%sens,G) call post_data(handles%id_total_sens, total_transport, diag) endif - if ((handles%id_sens_ga > 0) .and. ASSOCIATED(fluxes%sens)) then + if ((handles%id_sens_ga > 0) .and. associated(fluxes%sens)) then ave_flux = global_area_mean(fluxes%sens,G) call post_data(handles%id_sens_ga, ave_flux, diag) endif - if ((handles%id_heat_added > 0) .and. ASSOCIATED(fluxes%heat_added)) then + if ((handles%id_heat_added > 0) .and. associated(fluxes%heat_added)) then call post_data(handles%id_heat_added, fluxes%heat_added, diag) endif - if ((handles%id_total_heat_added > 0) .and. ASSOCIATED(fluxes%heat_added)) then + if ((handles%id_total_heat_added > 0) .and. associated(fluxes%heat_added)) then total_transport = global_area_integral(fluxes%heat_added,G) call post_data(handles%id_total_heat_added, total_transport, diag) endif @@ -2459,23 +2479,23 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) ! post the diagnostics for boundary salt fluxes ========================== - if ((handles%id_saltflux > 0) .and. ASSOCIATED(fluxes%salt_flux)) & + if ((handles%id_saltflux > 0) .and. associated(fluxes%salt_flux)) & call post_data(handles%id_saltflux, fluxes%salt_flux, diag) - if ((handles%id_total_saltflux > 0) .and. ASSOCIATED(fluxes%salt_flux)) then + if ((handles%id_total_saltflux > 0) .and. associated(fluxes%salt_flux)) then total_transport = ppt2mks*global_area_integral(fluxes%salt_flux,G) call post_data(handles%id_total_saltflux, total_transport, diag) endif - if ((handles%id_saltFluxAdded > 0) .and. ASSOCIATED(fluxes%salt_flux_added)) & + if ((handles%id_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) & call post_data(handles%id_saltFluxAdded, fluxes%salt_flux_added, diag) - if ((handles%id_total_saltFluxAdded > 0) .and. ASSOCIATED(fluxes%salt_flux_added)) then + if ((handles%id_total_saltFluxAdded > 0) .and. associated(fluxes%salt_flux_added)) then total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_added,G) call post_data(handles%id_total_saltFluxAdded, total_transport, diag) endif - if (handles%id_saltFluxIn > 0 .and. ASSOCIATED(fluxes%salt_flux_in)) & + if (handles%id_saltFluxIn > 0 .and. associated(fluxes%salt_flux_in)) & call post_data(handles%id_saltFluxIn, fluxes%salt_flux_in, diag) - if ((handles%id_total_saltFluxIn > 0) .and. ASSOCIATED(fluxes%salt_flux_in)) then + if ((handles%id_total_saltFluxIn > 0) .and. associated(fluxes%salt_flux_in)) then total_transport = ppt2mks*global_area_integral(fluxes%salt_flux_in,G) call post_data(handles%id_total_saltFluxIn, total_transport, diag) endif @@ -2496,13 +2516,13 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) ! remaining boundary terms ================================================== - if ((handles%id_psurf > 0) .and. ASSOCIATED(fluxes%p_surf)) & + if ((handles%id_psurf > 0) .and. associated(fluxes%p_surf)) & call post_data(handles%id_psurf, fluxes%p_surf, diag) - if ((handles%id_TKE_tidal > 0) .and. ASSOCIATED(fluxes%TKE_tidal)) & + if ((handles%id_TKE_tidal > 0) .and. associated(fluxes%TKE_tidal)) & call post_data(handles%id_TKE_tidal, fluxes%TKE_tidal, diag) - if ((handles%id_buoy > 0) .and. ASSOCIATED(fluxes%buoy)) & + if ((handles%id_buoy > 0) .and. associated(fluxes%buoy)) & call post_data(handles%id_buoy, fluxes%buoy, diag) @@ -2513,15 +2533,16 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type -subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, iceberg) +subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, iceberg, salt) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(forcing), intent(inout) :: fluxes !< Forcing fields structure + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes logical, optional, intent(in) :: heat !< If present and true, allocate heat fluxes logical, optional, intent(in) :: ustar !< If present and true, allocate ustar and related fields logical, optional, intent(in) :: press !< If present and true, allocate p_surf and related fields logical, optional, intent(in) :: shelf !< If present and true, allocate fluxes for ice-shelf logical, optional, intent(in) :: iceberg !< If present and true, allocate fluxes for icebergs + logical, optional, intent(in) :: salt !< If present and true, allocate salt fluxes ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -2552,6 +2573,8 @@ subroutine allocate_forcing_type(G, fluxes, water, heat, ustar, press, shelf, ic call myAlloc(fluxes%latent_fprec_diag,isd,ied,jsd,jed, heat) call myAlloc(fluxes%latent_frunoff_diag,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%salt_flux,isd,ied,jsd,jed, salt) + if (present(heat) .and. present(water)) then ; if (heat .and. water) then call myAlloc(fluxes%heat_content_cond,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_lprec,isd,ied,jsd,jed, .true.) @@ -2608,6 +2631,10 @@ subroutine allocate_mech_forcing(G, forces, stress, ustar, shelf, press, iceberg call myAlloc(forces%frac_shelf_u,IsdB,IedB,jsd,jed, shelf) call myAlloc(forces%frac_shelf_v,isd,ied,JsdB,JedB, shelf) + !These fields should only on allocated when iceberg area is being passed through the coupler. + call myAlloc(forces%area_berg,isd,ied,jsd,jed, iceberg) + call myAlloc(forces%mass_berg,isd,ied,jsd,jed, iceberg) + end subroutine allocate_mech_forcing !> Allocates and zeroes-out array. @@ -2620,7 +2647,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)) ; array(is:ie,js:je) = 0.0 endif ; endif ; endif end subroutine myAlloc @@ -2681,13 +2708,15 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%taux)) deallocate(forces%taux) if (associated(forces%tauy)) deallocate(forces%tauy) if (associated(forces%ustar)) deallocate(forces%ustar) - if (associated(forces%p_surf)) deallocate(forces%p_surf) - if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) + if (associated(forces%p_surf)) deallocate(forces%p_surf) + if (associated(forces%p_surf_full)) deallocate(forces%p_surf_full) if (associated(forces%net_mass_src)) deallocate(forces%net_mass_src) if (associated(forces%rigidity_ice_u)) deallocate(forces%rigidity_ice_u) if (associated(forces%rigidity_ice_v)) deallocate(forces%rigidity_ice_v) if (associated(forces%frac_shelf_u)) deallocate(forces%frac_shelf_u) if (associated(forces%frac_shelf_v)) deallocate(forces%frac_shelf_v) + if (associated(forces%area_berg)) deallocate(forces%area_berg) + if (associated(forces%mass_berg)) deallocate(forces%mass_berg) end subroutine deallocate_mech_forcing diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 7f40af8461..d302b2c152 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -90,10 +90,8 @@ module MOM_grid dyCu, & !< dyCu is delta y at u points, in m. IdyCu, & !< 1/dyCu in m-1. dy_Cu, & !< The unblocked lengths of the u-faces of the h-cell in m. - dy_Cu_obc, & !< The unblocked lengths of the u-faces of the h-cell in m for OBC. IareaCu, & !< The masked inverse areas of u-grid cells in m2. areaCu !< The areas of the u-grid cells in m2. - !> \todo dy_Cu_obc is not used? real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & mask2dCv, & !< 0 for boundary points and 1 for ocean points on the v grid. Nondim. @@ -104,7 +102,6 @@ module MOM_grid dyCv, & !< dyCv is delta y at v points, in m. IdyCv, & !< 1/dyCv in m-1. dx_Cv, & !< The unblocked lengths of the v-faces of the h-cell in m. - dx_Cv_obc, & !< The unblocked lengths of the v-faces of the h-cell in m for OBC. IareaCv, & !< The masked inverse areas of v-grid cells in m2. areaCv !< The areas of the v-grid cells in m2. @@ -437,9 +434,10 @@ logical function isPointInCell(G, i, j, x, y) endif end function isPointInCell +!> Store an integer indicating which direction to work on first. subroutine set_first_direction(G, y_first) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - integer, intent(in) :: y_first + integer, intent(in) :: y_first !< The first direction to store G%first_direction = y_first end subroutine set_first_direction @@ -504,8 +502,6 @@ subroutine allocate_metrics(G) ALLOC_(G%dx_Cv(isd:ied,JsdB:JedB)) ; G%dx_Cv(:,:) = 0.0 ALLOC_(G%dy_Cu(IsdB:IedB,jsd:jed)) ; G%dy_Cu(:,:) = 0.0 - ALLOC_(G%dx_Cv_obc(isd:ied,JsdB:JedB)) ; G%dx_Cv_obc(:,:) = 0.0 - ALLOC_(G%dy_Cu_obc(IsdB:IedB,jsd:jed)) ; G%dy_Cu_obc(:,:) = 0.0 ALLOC_(G%areaCu(IsdB:IedB,jsd:jed)) ; G%areaCu(:,:) = 0.0 ALLOC_(G%areaCv(isd:ied,JsdB:JedB)) ; G%areaCv(:,:) = 0.0 @@ -551,7 +547,6 @@ subroutine MOM_grid_end(G) DEALLOC_(G%geoLonCv) ; DEALLOC_(G%geoLonBu) DEALLOC_(G%dx_Cv) ; DEALLOC_(G%dy_Cu) - DEALLOC_(G%dx_Cv_obc) ; DEALLOC_(G%dy_Cu_obc) DEALLOC_(G%bathyT) ; DEALLOC_(G%CoriolisBu) DEALLOC_(G%dF_dx) ; DEALLOC_(G%dF_dy) @@ -574,18 +569,21 @@ end subroutine MOM_grid_end !! !! Grid metrics and their inverses are labelled according to their staggered location on a Arakawa C (or B) grid. !! - Metrics centered on h- or T-points are labelled T, e.g. dxT is the distance across the cell in the x-direction. -!! - Metrics centered on u-points are labelled Cu (C-grid u location). e.g. dyCu is the y-distance between two corners of a T-cell. +!! - Metrics centered on u-points are labelled Cu (C-grid u location). e.g. dyCu is the y-distance between +!! two corners of a T-cell. !! - Metrics centered on v-points are labelled Cv (C-grid v location). e.g. dyCv is the y-distance between two -points. !! - Metrics centered on q-points are labelled Bu (B-grid u,v location). e.g. areaBu is the area centered on a q-point. !! -!! \image html Grid_metrics.png "The labelling of distances (grid metrics) at various staggered location on an T-cell and around a q-point. +!! \image html Grid_metrics.png "The labelling of distances (grid metrics) at various staggered +!! location on an T-cell and around a q-point." !! !! Areas centered at T-, u-, v- and q- points are `areaT`, `areaCu`, `areaCv` and `areaBu` respectively. !! !! The reciprocal of metrics are pre-calculated and also stored in the ocean_grid_type with a I prepended to the name. !! For example, `1./areaT` is called `IareaT`, and `1./dyCv` is `IdyCv`. !! -!! Geographic latitude and longitude (or model coordinates if not on a sphere) are stored in `geoLatT`, `geoLonT` for T-points. +!! Geographic latitude and longitude (or model coordinates if not on a sphere) are stored in +!! `geoLatT`, `geoLonT` for T-points. !! u-, v- and q- point coordinates are follow same pattern of replacing T with Cu, Cv and Bu respectively. !! !! Each location also has a 2D mask indicating whether the entire column is land or ocean. diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index bb96f82fe4..c677f3863c 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -23,14 +23,19 @@ subroutine calc_isoneutral_slopes(G, GV, h, e, tv, dt_kappa_smooth, & type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface heights (m) - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, intent(in) :: dt_kappa_smooth + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: dt_kappa_smooth !< A vertical diffusive smoothing + !! timescale, in s. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: slope_x !< Isopycnal slope in i-direction (nondim) real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: slope_y !< Isopycnal slope in j-direction (nondim) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: N2_u !< Brunt-Vaisala frequency squared at u-points (s-2) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at u-points (s-2) - optional :: N2_u, N2_v - integer, optional, intent(in) :: halo !< Halo width over which to compute + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), & + optional, intent(inout) :: N2_u !< Brunt-Vaisala frequency squared at + !! interfaces between u-points (s-2) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), & + optional, intent(inout) :: N2_v !< Brunt-Vaisala frequency squared at + !! interfaces between u-points (s-2) + integer, optional, intent(in) :: halo !< Halo width over which to compute ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(G)) :: & T, & ! The temperature (or density) in C, with the values in @@ -307,16 +312,16 @@ end subroutine calc_isoneutral_slopes !> Returns tracer arrays (nominally T and S) with massless layers filled with !! sensible values, by diffusing vertically with a small but constant diffusivity. subroutine vert_fill_TS(h, T_in, S_in, kappa, dt, T_f, S_f, G, GV, halo_here) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_in !< Temperature (deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_in !< Salinity (psu) - real, intent(in) :: kappa !< A vertical diffusivity to use for smoothing (m2 s-1) - real, intent(in) :: dt !< The time increment, in s. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T_f !< Filled temperature (deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S_f !< Filed salinity (psu) - integer, optional, intent(in) :: halo_here !< Halo width over which to compute + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: T_in !< Temperature (deg C) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: S_in !< Salinity (psu) + real, intent(in) :: kappa !< A vertical diffusivity to use for smoothing (m2 s-1) + real, intent(in) :: dt !< The time increment, in s. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T_f !< Filled temperature (deg C) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S_f !< Filed salinity (psu) + integer, optional, intent(in) :: halo_here !< Halo width over which to compute ! Local variables real :: ent(SZI_(G),SZK_(G)+1) ! The diffusive entrainment (kappa*dt)/dz ! between layers in a timestep in m or kg m-2. diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 10754ff749..38eb78b89a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -18,7 +18,7 @@ module MOM_open_boundary use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char use MOM_string_functions, only : extract_word, remove_spaces -use MOM_tracer_registry, only : tracer_registry_type +use MOM_tracer_registry, only : tracer_type, tracer_registry_type, tracer_name_lookup use MOM_variables, only : thermo_var_ptrs use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init @@ -86,7 +86,9 @@ module MOM_open_boundary real, dimension(:,:,:), pointer :: t => NULL() !< tracer concentration array real :: OBC_inflow_conc = 0.0 !< tracer concentration for generic inflows character(len=32) :: name !< tracer name used for error messages - type(vardesc), pointer :: vd => NULL() !< metadata describing the tracer + type(tracer_type), pointer :: Tr => NULL() !< metadata describing the tracer + real, dimension(:,:,:), pointer :: tres => NULL() !< tracer reservoir array + logical :: is_initialized !< reservoir values have been set when True end type OBC_segment_tracer_type !> Registry type for tracers on segments @@ -103,9 +105,16 @@ module MOM_open_boundary logical :: Flather !< If true, applies Flather + Chapman radiation of barotropic gravity waves. logical :: radiation !< If true, 1D Orlanksi radiation boundary conditions are applied. !! If False, a gradient condition is applied. + logical :: radiation_tan !< If true, 1D Orlanksi radiation boundary conditions are applied to + !! tangential flows. + logical :: radiation_grad !< If true, 1D Orlanksi radiation boundary conditions are applied to + !! dudv and dvdx. logical :: oblique !< Oblique waves supported at radiation boundary. logical :: nudged !< Optional supplement to radiation boundary. - logical :: specified !< Boundary fixed to external value. + logical :: nudged_tan !< Optional supplement to nudge tangential velocity. + logical :: nudged_grad !< Optional supplement to nudge normal gradient of tangential velocity. + logical :: specified !< Boundary normal velocity fixed to external value. + logical :: specified_tan !< Boundary tangential velocity fixed to external value. logical :: open !< Boundary is open for continuity solver. logical :: gradient !< Zero gradient at boundary. logical :: values_needed !< Whether or not external OBC fields are needed. @@ -119,8 +128,8 @@ module MOM_open_boundary integer :: Ie_obc !< i-indices of boundary segment. integer :: Js_obc !< j-indices of boundary segment. integer :: Je_obc !< j-indices of boundary segment. - real :: Tnudge_in !< Inverse nudging timescale on inflow (1/s). - real :: Tnudge_out !< Inverse nudging timescale on outflow (1/s). + real :: Velocity_nudging_timescale_in !< Nudging timescale on inflow (s). + real :: Velocity_nudging_timescale_out !< Nudging timescale on outflow (s). logical :: on_pe !< true if segment is located in the computational domain logical :: temp_segment_data_exists !< true if temperature data arrays are present logical :: salt_segment_data_exists !< true if salinity data arrays are present @@ -130,6 +139,10 @@ module MOM_open_boundary real, pointer, dimension(:,:,:) :: h=>NULL() !< The cell thickness (m) at OBC-points. real, pointer, dimension(:,:,:) :: normal_vel=>NULL() !< The layer velocity normal to the OB !! segment (m s-1). + real, pointer, dimension(:,:,:) :: tangential_vel=>NULL() !< The layer velocity tangential to the + !! OB segment (m s-1). + real, pointer, dimension(:,:,:) :: tangential_grad=>NULL() !< The gradient of the velocity tangential + !! to the OB segment (m s-1). real, pointer, dimension(:,:,:) :: normal_trans=>NULL() !< The layer transport normal to the OB !! segment (m3 s-1). real, pointer, dimension(:,:) :: normal_vel_bt=>NULL() !< The barotropic velocity normal to @@ -141,10 +154,21 @@ module MOM_open_boundary !! segment (m s-1) real, pointer, dimension(:,:,:) :: rx_normal=>NULL() !< The rx_old_u value for radiation coeff !! for normal velocity + real, pointer, dimension(:,:,:) :: ry_normal=>NULL() !< The tangential value for radiation coeff + !! for normal velocity real, pointer, dimension(:,:,:) :: nudged_normal_vel=>NULL() !< The layer velocity normal to the OB segment !! that values should be nudged towards (m s-1). + real, pointer, dimension(:,:,:) :: nudged_tangential_vel=>NULL() !< The layer velocity tangential to the OB segment + !! that values should be nudged towards (m s-1). + real, pointer, dimension(:,:,:) :: nudged_tangential_grad=>NULL() !< The layer dvdx or dudy towards which nudging + !! can occur (s-1). type(segment_tracer_registry_type), pointer :: tr_Reg=> NULL()!< A pointer to the tracer registry for the segment. type(hor_index_type) :: HI !< Horizontal index ranges + real :: Tr_InvLscale3_out !< An effective inverse length scale cubed (m-3) + real :: Tr_InvLscale3_in !< for restoring the tracer concentration in a + !! ficticious reservior towards interior values + !! when flow is exiting the domain, or towards + !! an externally imposed value when flow is entering end type OBC_segment_type !> Open-boundary data @@ -177,9 +201,17 @@ module MOM_open_boundary logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the relative vorticity on open boundaries. + logical :: computed_vorticity = .false. !< If True, uses external data for tangential velocity + !! in the relative vorticity on open boundaries. + logical :: specified_vorticity = .false. !< If True, uses external data for tangential velocity + !! gradients in the relative vorticity on open boundaries. logical :: zero_strain = .false. !< If True, sets strain to zero on open boundaries. logical :: freeslip_strain = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the strain on open boundaries. + logical :: computed_strain = .false. !< If True, uses external data for tangential velocity to compute + !! normal gradient in the strain on open boundaries. + logical :: specified_strain = .false. !< If True, uses external data for tangential velocity gradients + !! to compute strain on open boundaries. logical :: zero_biharmonic = .false. !< If True, zeros the Laplacian of flow on open boundaries for !! use in the biharmonic viscosity term. logical :: brushcutter_mode = .false. !< If True, read data on supergrid. @@ -261,7 +293,7 @@ subroutine open_boundary_config(G, param_file, OBC) character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=100) :: 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 allocate(OBC) call log_version(param_file, mdl, version, "Controls where open boundaries are located, what "//& @@ -278,7 +310,7 @@ subroutine open_boundary_config(G, param_file, OBC) call get_param(param_file, mdl, "NK", OBC%ke, & "The number of model layers", default=0, do_not_log=.true.) - if (config1 .ne. "none") OBC%user_BCs_set_globally = .true. + if (config1 /= "none") OBC%user_BCs_set_globally = .true. if (OBC%number_of_segments > 0) then call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, & @@ -287,20 +319,48 @@ subroutine open_boundary_config(G, param_file, OBC) call get_param(param_file, mdl, "OBC_FREESLIP_VORTICITY", OBC%freeslip_vorticity, & "If true, sets the normal gradient of tangential velocity to\n"// & "zero in the relative vorticity on open boundaries. This cannot\n"// & - "be true if OBC_ZERO_VORTICITY is True.", default=.false.) - if (OBC%zero_vorticity .and. OBC%freeslip_vorticity) call MOM_error(FATAL, & - "MOM_open_boundary.F90, open_boundary_config: "//& - "Only one of OBC_ZERO_VORTICITY and OBC_FREESLIP_VORTICITY can be True at once.") + "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) + call get_param(param_file, mdl, "OBC_COMPUTED_VORTICITY", OBC%computed_vorticity, & + "If true, uses the external values of tangential velocity\n"// & + "in the relative vorticity on open boundaries. This cannot\n"// & + "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) + call get_param(param_file, mdl, "OBC_SPECIFIED_VORTICITY", OBC%specified_vorticity, & + "If true, uses the external values of tangential velocity\n"// & + "in the relative vorticity on open boundaries. This cannot\n"// & + "be true if another OBC_XXX_VORTICITY option is True.", default=.false.) + if ((OBC%zero_vorticity .and. OBC%freeslip_vorticity) .or. & + (OBC%zero_vorticity .and. OBC%computed_vorticity) .or. & + (OBC%zero_vorticity .and. OBC%specified_vorticity) .or. & + (OBC%freeslip_vorticity .and. OBC%computed_vorticity) .or. & + (OBC%freeslip_vorticity .and. OBC%specified_vorticity) .or. & + (OBC%computed_vorticity .and. OBC%specified_vorticity)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& + "Only one of OBC_ZERO_VORTICITY, OBC_FREESLIP_VORTICITY, OBC_COMPUTED_VORTICITY\n"//& + "and OBC_IMPORTED_VORTICITY can be True at once.") call get_param(param_file, mdl, "OBC_ZERO_STRAIN", OBC%zero_strain, & "If true, sets the strain used in the stress tensor to zero on open boundaries.", & default=.false.) call get_param(param_file, mdl, "OBC_FREESLIP_STRAIN", OBC%freeslip_strain, & "If true, sets the normal gradient of tangential velocity to\n"// & "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & - "be true if OBC_ZERO_STRAIN is True.", default=.false.) - if (OBC%zero_strain .and. OBC%freeslip_strain) call MOM_error(FATAL, & - "MOM_open_boundary.F90, open_boundary_config: "//& - "Only one of OBC_ZERO_STRAIN and OBC_FREESLIP_STRAIN can be True at once.") + "be true if another OBC_XXX_STRAIN option is True.", default=.false.) + call get_param(param_file, mdl, "OBC_COMPUTED_STRAIN", OBC%computed_strain, & + "If true, sets the normal gradient of tangential velocity to\n"// & + "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & + "be true if another OBC_XXX_STRAIN option is True.", default=.false.) + call get_param(param_file, mdl, "OBC_SPECIFIED_STRAIN", OBC%specified_strain, & + "If true, sets the normal gradient of tangential velocity to\n"// & + "zero in the strain use in the stress tensor on open boundaries. This cannot\n"// & + "be true if another OBC_XXX_STRAIN option is True.", default=.false.) + if ((OBC%zero_strain .and. OBC%freeslip_strain) .or. & + (OBC%zero_strain .and. OBC%computed_strain) .or. & + (OBC%zero_strain .and. OBC%specified_strain) .or. & + (OBC%freeslip_strain .and. OBC%computed_strain) .or. & + (OBC%freeslip_strain .and. OBC%specified_strain) .or. & + (OBC%computed_strain .and. OBC%specified_strain)) & + call MOM_error(FATAL, "MOM_open_boundary.F90, open_boundary_config:\n"//& + "Only one of OBC_ZERO_STRAIN, OBC_FREESLIP_STRAIN, OBC_COMPUTED_STRAIN\n"//& + "and OBC_IMPORTED_STRAIN can be True at once.") call get_param(param_file, mdl, "OBC_ZERO_BIHARMONIC", OBC%zero_biharmonic, & "If true, zeros the Laplacian of flow on open boundaries in the biharmonic\n"//& "viscosity term.", default=.false.) @@ -313,16 +373,17 @@ subroutine open_boundary_config(G, param_file, OBC) if (debug_OBC .or. debug) & call log_param(param_file, mdl, "DEBUG_OBC", debug_OBC, & "If true, do additional calls to help debug the performance \n"//& - "of the open boundary condition code.", default=.false.) + "of the open boundary condition code.", default=.false., & + debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary \n"//& "conditions for debugging.", units="m", default=0.0, & - do_not_log=.not.debug_OBC) + do_not_log=.not.debug_OBC, debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & "A silly value of velocities used outside of open boundary \n"//& "conditions for debugging.", units="m/s", default=0.0, & - do_not_log=.not.debug_OBC) + do_not_log=.not.debug_OBC, debuggingParam=.true.) ! Allocate everything ! Note the 0-segment is needed when %segnum_u/v(:,:) = 0 @@ -330,17 +391,22 @@ subroutine open_boundary_config(G, param_file, OBC) do l=0,OBC%number_of_segments OBC%segment(l)%Flather = .false. OBC%segment(l)%radiation = .false. + OBC%segment(l)%radiation_tan = .false. + OBC%segment(l)%radiation_grad = .false. OBC%segment(l)%oblique = .false. OBC%segment(l)%nudged = .false. + OBC%segment(l)%nudged_tan = .false. + OBC%segment(l)%nudged_grad = .false. OBC%segment(l)%specified = .false. + OBC%segment(l)%specified_tan = .false. OBC%segment(l)%open = .false. OBC%segment(l)%gradient = .false. OBC%segment(l)%values_needed = .false. OBC%segment(l)%direction = OBC_NONE OBC%segment(l)%is_N_or_S = .false. OBC%segment(l)%is_E_or_W = .false. - OBC%segment(l)%Tnudge_in = 0.0 - OBC%segment(l)%Tnudge_out = 0.0 + OBC%segment(l)%Velocity_nudging_timescale_in = 0.0 + OBC%segment(l)%Velocity_nudging_timescale_out = 0.0 OBC%segment(l)%num_fields = 0.0 enddo allocate(OBC%segnum_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; OBC%segnum_u(:,:) = OBC_NONE @@ -365,7 +431,7 @@ subroutine open_boundary_config(G, param_file, OBC) ! if (open_boundary_query(OBC, needs_ext_seg_data=.true.)) & call initialize_segment_data(G, OBC, param_file) - if ( OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally ) then + if (open_boundary_query(OBC, apply_Flather_OBC=.true.)) then call get_param(param_file, mdl, "OBC_RADIATION_MAX", OBC%rx_max, & "The maximum magnitude of the baroclinic radiation \n"//& "velocity (or speed of characteristics). This is only \n"//& @@ -386,8 +452,34 @@ subroutine open_boundary_config(G, param_file, OBC) "one of the open boundary segments is using Orlanski.", & units="nondim", default=0.2) endif + + Lscale_in = 0. + Lscale_out = 0. + if (open_boundary_query(OBC, apply_open_OBC=.true.)) then + call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_OUT ", Lscale_out, & + "An effective length scale for restoring the tracer concentration \n"//& + "at the boundaries to externally imposed values when the flow \n"//& + "is exiting the domain.", units="m", default=0.0) + + call get_param(param_file, mdl, "OBC_TRACER_RESERVOIR_LENGTH_SCALE_IN ", Lscale_in, & + "An effective length scale for restoring the tracer concentration \n"//& + "at the boundaries to values from the interior when the flow \n"//& + "is entering the domain.", units="m", default=0.0) + endif + if (mask_outside) call mask_outside_OBCs(G, param_file, OBC) - endif + + ! All tracers are using the same restoring length scale for now, but we may want to make this + ! tracer-specific in the future for example, in cases where certain tracers are poorly constrained + ! by data while others are well constrained - MJH. + do l = 1, OBC%number_of_segments + OBC%segment(l)%Tr_InvLscale3_in=0.0 + if (Lscale_in>0.) OBC%segment(l)%Tr_InvLscale3_in = 1.0/(Lscale_in*Lscale_in*Lscale_in) + OBC%segment(l)%Tr_InvLscale3_out=0.0 + if (Lscale_out>0.) OBC%segment(l)%Tr_InvLscale3_out = 1.0/(Lscale_out*Lscale_out*Lscale_out) + enddo + + endif ! OBC%number_of_segments > 0 ! Safety check if ((OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally) .and. & @@ -500,8 +592,8 @@ subroutine initialize_segment_data(G, OBC, PF) if (num_fields < 3) call MOM_error(FATAL, & "MOM_open_boundary, initialize_segment_data: "//& "Need at least three inputs for Flather") - segment%num_fields = num_fields ! these are at least three input fields required for the Flather option endif + segment%num_fields = num_fields ! these are at least three input fields required for the Flather option segment%temp_segment_data_exists=.false. segment%salt_segment_data_exists=.false. @@ -553,9 +645,17 @@ subroutine initialize_segment_data(G, OBC, PF) siz2(3)=siz(3) if (segment%is_E_or_W) then - allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz2(3))) + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + else + allocate(segment%field(m)%buffer_src(IsdB:IedB,jsd:jed,siz2(3))) + endif else - allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz2(3))) + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%buffer_src(IsdB:IedB,JsdB:JedB,siz2(3))) + else + allocate(segment%field(m)%buffer_src(isd:ied,JsdB:JedB,siz2(3))) + endif endif segment%field(m)%buffer_src(:,:,:)=0.0 segment%field(m)%fid = init_external_field(trim(filename),& @@ -564,9 +664,17 @@ subroutine initialize_segment_data(G, OBC, PF) fieldname = 'dz_'//trim(fieldname) call field_size(filename,fieldname,siz,no_domain=.true.) if (segment%is_E_or_W) then - allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3))) + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) + else + allocate(segment%field(m)%dz_src(IsdB:IedB,jsd:jed,siz(3))) + endif else - allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%dz_src(IsdB:IedB,JsdB:JedB,siz(3))) + else + allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) + endif endif segment%field(m)%dz_src(:,:,:)=0.0 segment%field(m)%nk_src=siz(3) @@ -587,8 +695,8 @@ subroutine initialize_segment_data(G, OBC, PF) end subroutine initialize_segment_data -!< Define indices for segment and store in hor_index_type -!< using global segment bounds corresponding to q-points +!> Define indices for segment and store in hor_index_type +!> using global segment bounds corresponding to q-points subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) type(dyn_horgrid_type), intent(in) :: G !< grid type type(OBC_segment_type), intent(inout) :: seg !< Open boundary segment @@ -599,9 +707,6 @@ subroutine setup_segment_indices(G, seg, Is_obc, Ie_obc, Js_obc, Je_obc) ! Local variables integer :: Isg,Ieg,Jsg,Jeg -! if (.not. G%Domain%symmetric) call MOM_error(FATAL, "MOM_open_boundary.F90, setup_segment_indices: "//& -! "Need to compile in symmetric mode") - ! Isg, Ieg will be I*_obc in global space if (Ie_obcJs_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_E - else if (Je_obc=G%HI%IedB) return ! Boundary is not on tile + if (I_obc<=G%HI%IsdB+1 .or. I_obc>=G%HI%IedB-1) return ! Boundary is not on tile if (Je_obc<=G%HI%JsdB .or. Js_obc>=G%HI%JedB) return ! Segment is not on tile OBC%segment(l_seg)%on_pe = .true. @@ -759,11 +876,13 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure character(len=*), intent(in) :: segment_str !< A string in form of "J=%,I=%:%,string" integer, intent(in) :: l_seg !< which segment is this? - type(param_file_type), intent(in) :: PF + type(param_file_type), intent(in) :: PF !< Parameter file handle ! Local variables integer :: J_obc, Is_obc, Ie_obc ! Position of segment in global index space integer :: i, a_loop - character(len=32) :: action_str(5) + character(len=32) :: action_str(8) + character(len=128) :: segment_param_str + real, allocatable, dimension(:) :: tnudge ! This returns the global indices for the segment call parse_segment_str(G%ieg, G%jeg, segment_str, J_obc, Is_obc, Ie_obc, action_str ) @@ -776,14 +895,14 @@ subroutine setup_v_point_obc(OBC, G, segment_str, l_seg, PF) if (Ie_obc>Is_obc) then OBC%segment(l_seg)%direction = OBC_DIRECTION_S - else if (Ie_obc=G%HI%JedB) return ! Boundary is not on tile + if (J_obc<=G%HI%JsdB+1 .or. J_obc>=G%HI%JedB-1) return ! Boundary is not on tile if (Ie_obc<=G%HI%IsdB .or. Is_obc>=G%HI%IedB) return ! Segment is not on tile OBC%segment(l_seg)%on_pe = .true. @@ -855,7 +996,8 @@ subroutine parse_segment_str(ni_global, nj_global, segment_str, l, m, n, action_ integer, intent(out) :: n !< The value of J=n, if segment_str begins with I=, or the value of I=n character(len=*), intent(out) :: action_str(:) !< The "string" part of segment_str ! Local variables - character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of "I=%,J=%:%,string" + character(len=24) :: word1, word2, m_word, n_word !< Words delineated by commas in a string in form of + !! "I=%,J=%:%,string" integer :: l_max !< Either ni_global or nj_global, depending on whether segment_str begins with "I=" or "J=" integer :: mn_max !< Either nj_global or ni_global, depending on whether segment_str begins with "I=" or "J=" integer :: j @@ -939,14 +1081,17 @@ end subroutine parse_segment_str !> Parse an OBC_SEGMENT_%%%_DATA string subroutine parse_segment_data_str(segment_str, var, value, filenam, fieldnam, fields, num_fields, 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), optional :: var !< The name of the variable for which parameters are needed - character(len=*), intent(out), optional :: filenam !< The name of the input file if using "file" method - character(len=*), intent(out), optional :: fieldnam !< The name of the variable in the input file if using "file" method - real, intent(out), optional :: value !< A constant value if using the "value" method - character(len=*), dimension(MAX_OBC_FIELDS), intent(out), optional :: fields !< List of fieldnames for each segment - integer, intent(out), optional :: num_fields - logical, intent(in), optional :: debug + character(len=*), intent(in) :: segment_str !< A string in form of + !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." + character(len=*), optional, intent(in) :: var !< The name of the variable for which parameters are needed + character(len=*), optional, intent(out) :: filenam !< The name of the input file if using "file" method + character(len=*), optional, intent(out) :: fieldnam !< The name of the variable in the input file if using + !! "file" method + real, optional, intent(out) :: value !< A constant value if using the "value" method + character(len=*), dimension(MAX_OBC_FIELDS), & + optional, intent(out) :: fields !< List of fieldnames for each segment + integer, optional, intent(out) :: num_fields !< The number of fields in the segment data + 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, orient @@ -1024,10 +1169,11 @@ end subroutine parse_segment_data_str !> 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, intent(in), optional :: 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, orient @@ -1118,13 +1264,14 @@ subroutine open_boundary_init(G, param_file, OBC) end subroutine open_boundary_init -logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, apply_nudged_OBC, needs_ext_seg_data) - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - logical, optional, intent(in) :: apply_open_OBC !< If present, returns True if specified_*_BCs_exist_globally is true - logical, optional, intent(in) :: apply_specified_OBC !< If present, returns True if specified_*_BCs_exist_globally is true - logical, optional, intent(in) :: apply_Flather_OBC !< If present, returns True if Flather_*_BCs_exist_globally is true - logical, optional, intent(in) :: apply_nudged_OBC !< If present, returns True if nudged_*_BCs_exist_globally is true - logical, optional, intent(in) :: needs_ext_seg_data !< If present, returns True if external segment data needed +logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, apply_Flather_OBC, & + apply_nudged_OBC, needs_ext_seg_data) + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + logical, optional, intent(in) :: apply_open_OBC !< Returns True if open_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_specified_OBC !< Returns True if specified_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_Flather_OBC !< Returns True if Flather_*_BCs_exist_globally is true + logical, optional, intent(in) :: apply_nudged_OBC !< Returns True if nudged_*_BCs_exist_globally is true + logical, optional, intent(in) :: needs_ext_seg_data !< Returns True if external segment data needed open_boundary_query = .false. if (.not. associated(OBC)) return if (present(apply_open_OBC)) open_boundary_query = OBC%open_u_BCs_exist_globally .or. & @@ -1174,12 +1321,13 @@ subroutine open_boundary_impose_normal_slope(OBC, G, depth) if (.not.associated(OBC)) return - if (.not.(OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) & + if (.not.(OBC%specified_u_BCs_exist_globally .or. OBC%specified_v_BCs_exist_globally .or. & + OBC%open_u_BCs_exist_globally .or. OBC%open_v_BCs_exist_globally)) & return do n=1,OBC%number_of_segments segment=>OBC%segment(n) - if (.not. segment%on_pe .or. segment%specified) cycle + if (.not. segment%on_pe) cycle if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed @@ -1221,7 +1369,7 @@ subroutine open_boundary_impose_land_mask(OBC, G, areaCu, areaCv) do n=1,OBC%number_of_segments segment=>OBC%segment(n) - if (.not. segment%on_pe .or. segment%specified) cycle + if (.not. segment%on_pe) cycle if (segment%is_E_or_W) then ! Sweep along u-segments and delete the OBC for blocked points. I=segment%HI%IsdB @@ -1328,14 +1476,18 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v_old !< Original unadjusted v real, intent(in) :: dt !< Appropriate timestep ! Local variables - real :: dhdt, dhdx, dhdy, gamma_u, gamma_h, gamma_v + real :: dhdt, dhdx, dhdy, gamma_u, gamma_h, gamma_v, gamma_2 real :: cff, Cx, Cy, tau real :: rx_max, ry_max ! coefficients for radiation real :: rx_new, rx_avg ! coefficients for radiation real :: ry_new, ry_avg ! coefficients for radiation + real, pointer, dimension(:,:,:) :: rx_tangential=>NULL() + real, pointer, dimension(:,:,:) :: ry_tangential=>NULL() real, parameter :: eps = 1.0e-20 type(OBC_segment_type), pointer :: segment integer :: i, j, k, is, ie, js, je, nz, n + integer :: is_obc, ie_obc, js_obc, je_obc + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke if (.not.associated(OBC)) return @@ -1360,7 +1512,24 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) do k=1,G%ke J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - segment%rx_normal(i,J,k) = OBC%ry_normal(i,J,k) + segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) + enddo + enddo + endif + if (segment%is_E_or_W .and. segment%oblique) then + do k=1,G%ke + I=segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + segment%rx_normal(I,j,k) = OBC%rx_normal(I,j,k) + segment%ry_normal(I,j,k) = OBC%ry_normal(I,j,k) + enddo + enddo + elseif (segment%is_N_or_S .and. segment%oblique) then + do k=1,G%ke + J=segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + segment%rx_normal(i,J,k) = OBC%rx_normal(i,J,k) + segment%ry_normal(i,J,k) = OBC%ry_normal(i,J,k) enddo enddo endif @@ -1393,23 +1562,17 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) elseif (segment%oblique) then dhdt = u_old(I-1,j,k)-u_new(I-1,j,k) !old-new dhdx = u_new(I-1,j,k)-u_new(I-2,j,k) !in new time backward sasha for I-1 -! if (segment%oblique) then - if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then - dhdy = segment%grad_normal(J-1,1,k) - elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then - dhdy = 0.0 - else - dhdy = segment%grad_normal(J,1,k) - endif -! endif + if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then + ry_new = segment%grad_normal(J-1,1,k) + elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then + ry_new = 0.0 + else + ry_new = segment%grad_normal(J,1,k) + endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - Cx = min(dhdt*dhdx,rx_max) ! default to normal radiation -! Cy = 0.0 - cff = max(dhdx*dhdx,eps) -! if (segment%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) -! endif + Cx = dhdt*dhdx + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cy = min(cff,max(dhdt*dhdy,-cff)) segment%normal_vel(I,j,k) = ((cff*u_new(I,j,k) + Cx*u_new(I-1,j,k)) - & (max(Cy,0.0)*segment%grad_normal(J-1,2,k) + min(Cy,0.0)*segment%grad_normal(J,2,k))) / (cff + Cx) elseif (segment%gradient) then @@ -1417,19 +1580,81 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then if (dhdt*dhdx < 0.0) then - tau = segment%Tnudge_in + tau = segment%Velocity_nudging_timescale_in else - tau = segment%Tnudge_out + tau = segment%Velocity_nudging_timescale_out endif - segment%normal_vel(I,j,k) = u_new(I,j,k) + dt*tau*(segment%nudged_normal_vel(I,j,k) - u_new(I,j,k)) + gamma_2 = dt / (tau + dt) + segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & + gamma_2 * segment%nudged_normal_vel(I,j,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + enddo + enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(I,J,k) + rx_avg*v_new(I-1,J,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo endif - enddo; enddo + if (segment%radiation_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc + rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCu(I-1,j) > 0.0 .and. G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I-1,j,k) + u_new(I-1,j+1,k))*dt*G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j) > 0.0) then +! rx_avg = u_new(I-1,j,k)*dt*G%IdxBu(I-1,J) +! elseif (G%mask2dCu(I-1,j+1) > 0.0) then +! rx_avg = u_new(I-1,j+1,k)*dt*G%IdxBu(I-1,J) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((v_new(i,J,k) - v_new(i-1,J,k))*G%IdxBu(I-1,J) + & + rx_avg*(v_new(i-1,J,k) - v_new(i-2,J,k))*G%IdxBu(I-2,J)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif endif if (segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB if (I>G%HI%IecB) cycle - do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed if (segment%radiation) then dhdt = u_old(I+1,j,k)-u_new(I+1,j,k) !old-new dhdx = u_new(I+1,j,k)-u_new(I+2,j,k) !in new time forward sasha for I+1 @@ -1447,23 +1672,17 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) elseif (segment%oblique) then dhdt = u_old(I+1,j,k)-u_new(I+1,j,k) !old-new dhdx = u_new(I+1,j,k)-u_new(I+2,j,k) !in new time forward sasha for I+1 -! if (segment%oblique) then - if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then - dhdy = segment%grad_normal(J-1,1,k) - elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then - dhdy = 0.0 - else - dhdy = segment%grad_normal(J,1,k) - endif -! endif + if (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) > 0.0) then + dhdy = segment%grad_normal(J-1,1,k) + elseif (dhdt*(segment%grad_normal(J,1,k) + segment%grad_normal(J-1,1,k)) == 0.0) then + dhdy = 0.0 + else + dhdy = segment%grad_normal(J,1,k) + endif if (dhdt*dhdx < 0.0) dhdt = 0.0 - Cx = min(dhdt*dhdx,rx_max) ! default to normal flow only -! Cy = 0. - cff = max(dhdx*dhdx, eps) -! if (segment%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cy = min(cff,max(dhdt*dhdy,-cff)) -! endif + Cx = dhdt*dhdx + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cy = min(cff,max(dhdt*dhdy,-cff)) segment%normal_vel(I,j,k) = ((cff*u_new(I,j,k) + Cx*u_new(I+1,j,k)) - & (max(Cy,0.0)*segment%grad_normal(J-1,2,k) + min(Cy,0.0)*segment%grad_normal(J,2,k))) / (cff + Cx) elseif (segment%gradient) then @@ -1471,13 +1690,75 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then if (dhdt*dhdx < 0.0) then - tau = segment%Tnudge_in + tau = segment%Velocity_nudging_timescale_in else - tau = segment%Tnudge_out + tau = segment%Velocity_nudging_timescale_out endif - segment%normal_vel(I,j,k) = u_new(I,j,k) + dt*tau*(segment%nudged_normal_vel(I,j,k) - u_new(I,j,k)) + gamma_2 = dt / (tau + dt) + segment%normal_vel(I,j,k) = (1 - gamma_2) * segment%normal_vel(I,j,k) + & + gamma_2 * segment%nudged_normal_vel(I,j,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + I=segment%HI%IsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(I,segment%HI%JsdB,k) = segment%rx_normal(I,segment%HI%jsd,k) + rx_tangential(I,segment%HI%JedB,k) = segment%rx_normal(I,segment%HI%jed,k) + do J=segment%HI%JsdB+1,segment%HI%JedB-1 + rx_tangential(I,J,k) = 0.5*(segment%rx_normal(I,j,k) + segment%rx_normal(I,j+1,k)) + enddo + enddo + if (segment%radiation_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (v_new(I+1,J,k) + rx_avg*v_new(I+2,J,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo endif - enddo; enddo + if (segment%radiation_grad) then + Js_obc = max(segment%HI%JsdB,G%jsd+1) + Je_obc = min(segment%HI%JedB,G%jed-1) + do k=1,nz ; do J=Js_obc,Je_obc + rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCu(I+1,j) > 0.0 .and. G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = 0.5*(u_new(I+1,j,k) + u_new(I+1,j+1,k))*dt*G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j) > 0.0) then +! rx_avg = u_new(I+1,j,k)*dt*G%IdxBu(I+1,J) +! elseif (G%mask2dCu(I+1,j+1) > 0.0) then +! rx_avg = u_new(I+1,j+1,k)*dt*G%IdxBu(I+1,J) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((v_new(i+2,J,k) - v_new(i+1,J,k))*G%IdxBu(I+1,J) + & + rx_avg*(v_new(i+3,J,k) - v_new(i+2,J,k))*G%IdxBu(I+2,J)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif endif if (segment%direction == OBC_DIRECTION_N) then @@ -1489,35 +1770,30 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdy = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - ry_avg = (1.0-gamma_v)*segment%rx_normal(I,j,k) + gamma_v*ry_new - segment%rx_normal(i,J,k) = ry_avg + ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + segment%ry_normal(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J-1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J-1,k)) / (1.0+ry_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%rx_normal(i,J,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) elseif (segment%oblique) then dhdt = v_old(i,J-1,k)-v_new(i,J-1,k) !old-new dhdy = v_new(i,J-1,k)-v_new(i,J-2,k) !in new time backward sasha for J-1 -! if (segment%oblique) then - if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then - dhdx = segment%grad_normal(I-1,1,k) - elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then - dhdx = 0.0 - else - dhdx = segment%grad_normal(I,1,k) - endif -! endif + segment%ry_normal(i,J,k) = ry_avg + if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then + dhdx = segment%grad_normal(I-1,1,k) + elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_normal(I,1,k) + endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (segment%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif + Cy = dhdt*dhdy + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = min(cff,max(dhdt*dhdx,-cff)) segment%normal_vel(i,J,k) = ((cff*v_new(i,J,k) + Cy*v_new(i,J-1,k)) - & (max(Cx,0.0)*segment%grad_normal(I-1,2,k) + min(Cx,0.0)*segment%grad_normal(I,2,k))) / (cff + Cy) elseif (segment%gradient) then @@ -1525,13 +1801,75 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then if (dhdt*dhdy < 0.0) then - tau = segment%Tnudge_in + tau = segment%Velocity_nudging_timescale_in else - tau = segment%Tnudge_out + tau = segment%Velocity_nudging_timescale_out endif - segment%normal_vel(i,J,k) = v_new(i,J,k) + dt*tau*(segment%nudged_normal_vel(i,J,k) - v_new(i,J,k)) + gamma_2 = dt / (tau + dt) + segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & + gamma_2 * segment%nudged_normal_vel(i,J,k) endif - enddo; enddo + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + J=segment%HI%JsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + enddo + enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j,k) + rx_avg*u_new(I,j-1,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc + rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCv(i,J-1) > 0.0 .and. G%mask2dCv(i+1,J-1) > 0.0) then +! rx_avg = 0.5*(v_new(i,J-1,k) + v_new(i+1,J-1,k)*dt*G%IdyBu(I,J-1)) +! elseif (G%mask2dCv(i,J-1) > 0.0) then +! rx_avg = v_new(i,J-1,k)*dt*G%IdyBu(I,J-1) +! elseif (G%mask2dCv(i+1,J-1) > 0.0) then +! rx_avg = v_new(i+1,J-1,k)*dt*G%IdyBu(I,J-1) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((u_new(I,j,k) - u_new(I-1,j,k))*G%IdyBu(I,J-1) + & + rx_avg*(u_new(I,j-1,k) - u_new(I,j-2,k))*G%IdyBu(I,J-2)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo + endif + deallocate(rx_tangential) + endif endif @@ -1544,35 +1882,29 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) dhdy = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J-1 ry_new = 0.0 if (dhdt*dhdy > 0.0) ry_new = min( (dhdt/dhdy), ry_max) - ry_avg = (1.0-gamma_v)*segment%rx_normal(I,j,k) + gamma_v*ry_new - segment%rx_normal(i,J,k) = ry_avg + ry_avg = (1.0-gamma_v)*segment%ry_normal(I,j,k) + gamma_v*ry_new + segment%ry_normal(i,J,k) = ry_avg ! The new boundary value is interpolated between future interior ! value, v_new(J+1) and past boundary value but with barotropic ! accelerations, v_new(J). segment%normal_vel(i,J,k) = (v_new(i,J,k) + ry_avg*v_new(i,J+1,k)) / (1.0+ry_avg) ! Copy restart fields into 3-d arrays. This is an inefficient and temporary issues ! implemented as a work-around to limitations in restart capability - OBC%ry_normal(i,J,k) = segment%rx_normal(i,J,k) + OBC%ry_normal(i,J,k) = segment%ry_normal(i,J,k) elseif (segment%oblique) then dhdt = v_old(i,J+1,k)-v_new(i,J+1,k) !old-new dhdy = v_new(i,J+1,k)-v_new(i,J+2,k) !in new time backward sasha for J-1 -! if (segment%oblique) then - if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then - dhdx = segment%grad_normal(I-1,1,k) - elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then - dhdx = 0.0 - else - dhdx = segment%grad_normal(I,1,k) - endif -! endif + if (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) > 0.0) then + dhdx = segment%grad_normal(I-1,1,k) + elseif (dhdt*(segment%grad_normal(I,1,k) + segment%grad_normal(I-1,1,k)) == 0.0) then + dhdx = 0.0 + else + dhdx = segment%grad_normal(I,1,k) + endif if (dhdt*dhdy < 0.0) dhdt = 0.0 - Cy = min(dhdt*dhdy,rx_max) ! default to normal flow only -! Cx = 0 - cff = max(dhdy*dhdy, eps) -! if (segment%oblique) then - cff = max(dhdx*dhdx + dhdy*dhdy, eps) - Cx = min(cff,max(dhdt*dhdx,-cff)) -! endif + Cy = dhdt*dhdy + cff = max(dhdx*dhdx + dhdy*dhdy, eps) + Cx = min(cff,max(dhdt*dhdx,-cff)) segment%normal_vel(i,J,k) = ((cff*v_new(i,J,k) + Cy*v_new(i,J+1,k)) - & (max(Cx,0.0)*segment%grad_normal(I-1,2,k) + min(Cx,0.0)*segment%grad_normal(I,2,k))) / (cff + Cy) elseif (segment%gradient) then @@ -1580,14 +1912,76 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, dt) endif if ((segment%radiation .or. segment%oblique) .and. segment%nudged) then if (dhdt*dhdy < 0.0) then - tau = segment%Tnudge_in + tau = segment%Velocity_nudging_timescale_in else - tau = segment%Tnudge_out + tau = segment%Velocity_nudging_timescale_out endif - segment%normal_vel(i,J,k) = v_new(i,J,k) + dt*tau*(segment%nudged_normal_vel(i,J,k) - v_new(i,J,k)) + gamma_2 = dt / (tau + dt) + segment%normal_vel(i,J,k) = (1 - gamma_2) * segment%normal_vel(i,J,k) + & + gamma_2 * segment%nudged_normal_vel(i,J,k) + endif + enddo ; enddo + if (segment%radiation_tan .or. segment%radiation_grad) then + J=segment%HI%JsdB + allocate(rx_tangential(segment%HI%IsdB:segment%HI%IedB,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz + rx_tangential(segment%HI%IsdB,J,k) = segment%ry_normal(segment%HI%isd,J,k) + rx_tangential(segment%HI%IedB,J,k) = segment%ry_normal(segment%HI%ied,J,k) + do I=segment%HI%IsdB+1,segment%HI%IedB-1 + rx_tangential(I,J,k) = 0.5*(segment%ry_normal(i,J,k) + segment%ry_normal(i+1,J,k)) + enddo + enddo + if (segment%radiation_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + rx_avg = rx_tangential(I,J,k) + segment%tangential_vel(I,J,k) = (u_new(I,j+1,k) + rx_avg*u_new(I,j+2,k)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_tan) then + do k=1,nz ; do I=segment%HI%IsdB,segment%HI%IedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_vel(I,J,k) = (1 - gamma_2) * segment%tangential_vel(I,J,k) + & + gamma_2 * segment%nudged_tangential_vel(I,J,k) + enddo ; enddo + endif + if (segment%radiation_grad) then + Is_obc = max(segment%HI%IsdB,G%isd+1) + Ie_obc = min(segment%HI%IedB,G%ied-1) + do k=1,nz ; do I=Is_obc,Ie_obc + rx_avg = rx_tangential(I,J,k) +! if (G%mask2dCv(i,J+1) > 0.0 .and. G%mask2dCv(i+1,J+1) > 0.0) then +! rx_avg = 0.5*(v_new(i,J+1,k) + v_new(i+1,J+1,k))*dt*G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i,J+1) > 0.0) then +! rx_avg = v_new(i,J+1,k)*dt*G%IdyBu(I,J+1) +! elseif (G%mask2dCv(i+1,J+1) > 0.0) then +! rx_avg = v_new(i+1,J+1,k)*dt*G%IdyBu(I,J+1) +! else +! rx_avg = 0.0 +! endif + segment%tangential_grad(I,J,k) = ((u_new(I,j+2,k) - u_new(I,j+1,k))*G%IdyBu(I,J+1) + & + rx_avg*(u_new(I,j+3,k) - u_new(I,j+2,k))*G%IdyBu(I,J+2)) / (1.0+rx_avg) + enddo ; enddo + endif + if (segment%nudged_grad) then + do k=1,nz ; do J=segment%HI%JsdB,segment%HI%JedB + if (rx_tangential(I,J,k) < 0.0) then + tau = segment%Velocity_nudging_timescale_in + else + tau = segment%Velocity_nudging_timescale_out + endif + gamma_2 = dt / (tau + dt) + segment%tangential_grad(I,J,k) = (1 - gamma_2) * segment%tangential_grad(I,J,k) + & + gamma_2 * segment%nudged_tangential_grad(I,J,k) + enddo ; enddo endif - enddo; enddo - end if + deallocate(rx_tangential) + endif + endif enddo ! Actually update u_new, v_new @@ -1619,12 +2013,12 @@ subroutine open_boundary_apply_normal_flow(OBC, G, u, v) I=segment%HI%IsdB do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed u(I,j,k) = segment%normal_vel(I,j,k) - enddo; enddo + enddo ; enddo elseif (segment%is_N_or_S) then J=segment%HI%JsdB do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied v(i,J,k) = segment%normal_vel(i,J,k) - enddo; enddo + enddo ; enddo endif endif enddo @@ -1652,12 +2046,12 @@ subroutine open_boundary_zero_normal_flow(OBC, G, u, v) I=segment%HI%IsdB do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed u(I,j,k) = 0. - enddo; enddo + enddo ; enddo elseif (segment%is_N_or_S) then J=segment%HI%JsdB do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied v(i,J,k) = 0. - enddo; enddo + enddo ; enddo endif enddo @@ -1691,7 +2085,7 @@ subroutine gradient_at_q_points(G,segment,uvel,vvel) enddo enddo endif - else if (segment%is_N_or_S) then + elseif (segment%is_N_or_S) then if (segment%direction == OBC_DIRECTION_N) then J=segment%HI%jsdB do k=1,G%ke @@ -1755,22 +2149,22 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) I=segment%HI%IsdB do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed tv%T(i+1,j,k) = tv%T(i,j,k) ; tv%S(i+1,j,k) = tv%S(i,j,k) - enddo; enddo + enddo ; enddo elseif (segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed tv%T(i,j,k) = tv%T(i+1,j,k) ; tv%S(i,j,k) = tv%S(i+1,j,k) - enddo; enddo + enddo ; enddo elseif (segment%direction == OBC_DIRECTION_N) then J=segment%HI%JsdB do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied tv%T(i,j+1,k) = tv%T(i,j,k) ; tv%S(i,j+1,k) = tv%S(i,j,k) - enddo; enddo + enddo ; enddo elseif (segment%direction == OBC_DIRECTION_S) then J=segment%HI%JsdB do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied tv%T(i,j,k) = tv%T(i,j+1,k) ; tv%S(i,j,k) = tv%S(i,j+1,k) - enddo; enddo + enddo ; enddo endif enddo endif @@ -1783,22 +2177,22 @@ subroutine set_tracer_data(OBC, tv, h, G, PF, tracer_Reg) ! I=segment%HI%IsdB ! do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed ! h(i+1,j,k) = h(i,j,k) -! enddo; enddo +! enddo ; enddo ! elseif (segment%direction == OBC_DIRECTION_W) then ! I=segment%HI%IsdB ! do k=1,G%ke ; do j=segment%HI%jsd,segment%HI%jed ! h(i,j,k) = h(i+1,j,k) -! enddo; enddo +! enddo ; enddo ! elseif (segment%direction == OBC_DIRECTION_N) then ! J=segment%HI%JsdB ! do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied ! h(i,j+1,k) = h(i,j,k) -! enddo; enddo +! enddo ; enddo ! elseif (segment%direction == OBC_DIRECTION_S) then ! J=segment%HI%JsdB ! do k=1,G%ke ; do i=segment%HI%isd,segment%HI%ied ! h(i,j,k) = h(i,j+1,k) -! enddo; enddo +! enddo ; enddo ! endif ! enddo @@ -1850,7 +2244,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%eta(IsdB:IedB,jsd:jed)); segment%eta(:,:)=0.0 allocate(segment%normal_trans_bt(IsdB:IedB,jsd:jed)); segment%normal_trans_bt(:,:)=0.0 if (segment%radiation) then - allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 endif allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke)); segment%normal_vel(:,:,:)=0.0 allocate(segment%normal_vel_bt(IsdB:IedB,jsd:jed)); segment%normal_vel_bt(:,:)=0.0 @@ -1858,8 +2252,23 @@ subroutine allocate_OBC_segment_data(OBC, segment) if (segment%nudged) then allocate(segment%nudged_normal_vel(IsdB:IedB,jsd:jed,OBC%ke)); segment%nudged_normal_vel(:,:,:)=0.0 endif + if (OBC%computed_vorticity .or. segment%nudged_tan .or. segment%specified_tan .or. & + OBC%computed_strain) then + allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_vel(:,:,:)=0.0 + endif + if (segment%nudged_tan) then + allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_vel(:,:,:)=0.0 + endif + if (segment%nudged_grad) then + allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_grad(:,:,:)=0.0 + endif + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad) then + allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 + endif if (segment%oblique) then - allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%grad_normal(JsdB:JedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%rx_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%ry_normal(IsdB:IedB,jsd:jed,OBC%ke)); segment%ry_normal(:,:,:)=0.0 endif endif @@ -1871,7 +2280,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%eta(isd:ied,JsdB:JedB)); segment%eta(:,:)=0.0 allocate(segment%normal_trans_bt(isd:ied,JsdB:JedB)); segment%normal_trans_bt(:,:)=0.0 if (segment%radiation) then - allocate(segment%rx_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 endif allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke)); segment%normal_vel(:,:,:)=0.0 allocate(segment%normal_vel_bt(isd:ied,JsdB:JedB)); segment%normal_vel_bt(:,:)=0.0 @@ -1879,8 +2288,23 @@ subroutine allocate_OBC_segment_data(OBC, segment) if (segment%nudged) then allocate(segment%nudged_normal_vel(isd:ied,JsdB:JedB,OBC%ke)); segment%nudged_normal_vel(:,:,:)=0.0 endif + if (OBC%computed_vorticity .or. segment%nudged_tan .or. segment%specified_tan .or. & + OBC%computed_strain) then + allocate(segment%tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_vel(:,:,:)=0.0 + endif + if (segment%nudged_tan) then + allocate(segment%nudged_tangential_vel(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_vel(:,:,:)=0.0 + endif + if (segment%nudged_grad) then + allocate(segment%nudged_tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%nudged_tangential_grad(:,:,:)=0.0 + endif + if (OBC%specified_vorticity .or. OBC%specified_strain .or. segment%radiation_grad) then + allocate(segment%tangential_grad(IsdB:IedB,JsdB:JedB,OBC%ke)); segment%tangential_grad(:,:,:)=0.0 + endif if (segment%oblique) then - allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%grad_normal(IsdB:IedB,2,OBC%ke)); segment%grad_normal(:,:,:) = 0.0 + allocate(segment%rx_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%rx_normal(:,:,:)=0.0 + allocate(segment%ry_normal(isd:ied,JsdB:JedB,OBC%ke)); segment%ry_normal(:,:,:)=0.0 endif endif @@ -1901,10 +2325,14 @@ subroutine deallocate_OBC_segment_data(OBC, segment) if (associated (segment%eta)) deallocate(segment%eta) if (associated (segment%normal_trans_bt)) deallocate(segment%normal_trans_bt) if (associated (segment%rx_normal)) deallocate(segment%rx_normal) + if (associated (segment%ry_normal)) deallocate(segment%ry_normal) if (associated (segment%normal_vel)) deallocate(segment%normal_vel) if (associated (segment%normal_vel_bt)) deallocate(segment%normal_vel_bt) if (associated (segment%normal_trans)) deallocate(segment%normal_trans) if (associated (segment%nudged_normal_vel)) deallocate(segment%nudged_normal_vel) + if (associated (segment%tangential_vel)) deallocate(segment%tangential_vel) + if (associated (segment%nudged_tangential_vel)) deallocate(segment%nudged_tangential_vel) + if (associated (segment%tangential_grad)) deallocate(segment%tangential_grad) if (associated (segment%tr_Reg)) call segment_tracer_registry_end(segment%tr_Reg) @@ -2021,8 +2449,9 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) real, dimension(:,:), pointer :: seg_vel => NULL() ! pointer to segment velocity array real, dimension(:,:), pointer :: seg_trans => NULL() ! pointer to segment transport array real, dimension(:,:,:), allocatable :: tmp_buffer - integer :: subsample_factor + real, dimension(:), allocatable :: h_stack integer :: is_obc2, js_obc2 + real :: net_H_src, net_H_int, scl_fac is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2031,11 +2460,6 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (.not. associated(OBC)) return - if (OBC%brushcutter_mode) then - subsample_factor = 2 - else - subsample_factor = 1 - endif do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -2048,16 +2472,6 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) js_obc = max(segment%js_obc,jsd-1) je_obc = min(segment%je_obc,jed) - if (OBC%brushcutter_mode) then - if (segment%is_E_or_W) then - nj_seg=nj_seg-1 - js_obc=js_obc+1 - else - ni_seg=ni_seg-1 - is_obc=is_obc+1 - endif - endif - ! Calculate auxiliary fields at staggered locations. ! Segment indices are on q points: ! @@ -2074,34 +2488,27 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed segment%Cg(I,j) = sqrt(GV%g_prime(1)*G%bathyT(i+ishift,j)) - ! if (GV%Boussinesq) then - segment%Htot(I,j) = G%bathyT(i+ishift,j)*GV%m_to_H! + eta(i+ishift,j) - ! else - ! segment%Htot(I,j) = eta(i+ishift,j) - ! endif + segment%Htot(I,j)=0.0 do k=1,G%ke segment%h(I,j,k) = h(i+ishift,j,k) + segment%Htot(I,j)=segment%Htot(I,j)+segment%h(I,j,k) enddo enddo - - else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) if (segment%direction == OBC_DIRECTION_S) jshift=1 J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%Cg(i,J) = sqrt(GV%g_prime(1)*G%bathyT(i,j+jshift)) -! if (GV%Boussinesq) then - segment%Htot(i,J) = G%bathyT(i,j+jshift)*GV%m_to_H! + eta(i,j+jshift) -! else -! segment%Htot(i,J) = eta(i,j+jshift) -! endif + segment%Htot(i,J)=0.0 do k=1,G%ke segment%h(i,J,k) = h(i,j+jshift,k) -! segment%e(i,J,k) = e(i,j+jshift,k) + segment%Htot(i,J)=segment%Htot(i,J)+segment%h(i,J,k) enddo enddo endif + allocate(h_stack(G%ke)) + h_stack(:) = 0.0 do m = 1,segment%num_fields if (segment%field(m)%fid > 0) then siz(1)=size(segment%field(m)%buffer_src,1) @@ -2110,115 +2517,338 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (.not.associated(segment%field(m)%buffer_dst)) then if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency') if (segment%field(m)%nk_src > 1) then - if (OBC%brushcutter_mode) then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) - else - if (segment%is_E_or_W) then + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) + endif + if (segment%field(m)%name == 'U') then + allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) + segment%field(m)%bt_vel(:,:)=0.0 + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) endif + if (segment%field(m)%name == 'V') then + allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) + segment%field(m)%bt_vel(:,:)=0.0 + endif endif else - if (OBC%brushcutter_mode) then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) - else - if (segment%is_E_or_W) then + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) + else allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,1)) + endif + if (segment%field(m)%name == 'U') then + allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) + segment%field(m)%bt_vel(:,:)=0.0 + endif + else + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,1)) else allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,1)) endif + if (segment%field(m)%name == 'V') then + allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) + segment%field(m)%bt_vel(:,:)=0.0 + endif endif endif segment%field(m)%buffer_dst(:,:,:)=0.0 - if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then - allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) - segment%field(m)%bt_vel(:,:)=0.0 - endif endif ! read source data interpolated to the current model time if (siz(1)==1) then - allocate(tmp_buffer(1,(nj_seg+1)*subsample_factor-1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid + if (OBC%brushcutter_mode) then + allocate(tmp_buffer(1,nj_seg*2-1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid + else + allocate(tmp_buffer(1,nj_seg,segment%field(m)%nk_src)) ! segment data is currrently on supergrid + endif else - allocate(tmp_buffer((ni_seg+1)*subsample_factor-1,1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid + if (OBC%brushcutter_mode) then + allocate(tmp_buffer(ni_seg*2-1,1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid + else + allocate(tmp_buffer(ni_seg,1,segment%field(m)%nk_src)) ! segment data is currrently on supergrid + endif endif call time_interp_external(segment%field(m)%fid,Time, tmp_buffer) if (OBC%brushcutter_mode) then - if (siz(1)==1) then - segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)-1:2*(je_obc+G%jdg_offset)-1:2,:) + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + segment%field(m)%buffer_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) + else + segment%field(m)%buffer_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) + endif else - segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)-1:2*(ie_obc+G%idg_offset)-1:2,1,:) + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + segment%field(m)%buffer_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) + else + segment%field(m)%buffer_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset):2,1,:) + endif endif else - if (siz(1)==1) then - segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset+1,:) + else + segment%field(m)%buffer_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) + endif else - segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset+1,1,:) + else + segment%field(m)%buffer_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) + endif endif endif if (segment%field(m)%nk_src > 1) then call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer) if (OBC%brushcutter_mode) then - if (siz(1)==1) then - segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,2*(js_obc+G%jdg_offset)-1:2*(je_obc+G%jdg_offset)-1:2,:) + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + segment%field(m)%dz_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset)+1:2,:) + else + segment%field(m)%dz_src(is_obc,:,:) = & + tmp_buffer(1,2*(js_obc+G%jdg_offset)+1:2*(je_obc+G%jdg_offset):2,:) + endif else - segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(2*(is_obc+G%idg_offset)-1:2*(ie_obc+G%idg_offset)-1:2,1,:) + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + segment%field(m)%dz_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset)+1:2,1,:) + else + segment%field(m)%dz_src(:,js_obc,:) = & + tmp_buffer(2*(is_obc+G%idg_offset)+1:2*(ie_obc+G%idg_offset):2,1,:) + endif endif else - if (siz(1)==1) then - segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset+1,:) + else + segment%field(m)%dz_src(is_obc,:,:)=tmp_buffer(1,js_obc+G%jdg_offset+1:je_obc+G%jdg_offset,:) + endif else - segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset+1,1,:) + else + segment%field(m)%dz_src(:,js_obc,:)=tmp_buffer(is_obc+G%idg_offset+1:ie_obc+G%idg_offset,1,:) + endif endif endif if (segment%is_E_or_W) then ishift=1 if (segment%direction == OBC_DIRECTION_E) ishift=0 - do j=js_obc+1,je_obc - I=is_obc - ! Using the h remapping approach - ! Pretty sure we need to check for source/target grid consistency here - segment%field(m)%buffer_dst(I,j,:)=0.0 ! initialize remap destination buffer - if (G%mask2dCu(I,j)>0.) then - 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,:), & - G%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) - endif - enddo + I=is_obc + if (segment%field(m)%name == 'V' .or. segment%field(m)%name == 'DVDX') then + ! Do q points for the whole segment + do J=max(js_obc,jsd),min(je_obc,jed-1) + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(I,J,:)=0.0 ! initialize remap destination buffer + if (G%mask2dCu(I,j)>0. .and. G%mask2dCu(I,j+1)>0.) then + h_stack(:) = 0.5*(h(i+ishift,j,:) + 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,:), & + G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + 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,:), & + G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + 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,:), & + G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + endif + enddo + else + do j=js_obc+1,je_obc + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(I,j,:)=0.0 ! initialize remap destination buffer + if (G%mask2dCu(I,j)>0.) then + net_H_src = sum( segment%field(m)%dz_src(I,j,:) ) + net_H_int = sum( h(i+ishift,j,:) ) + scl_fac = net_H_int / net_H_src + 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,:), & + G%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) + endif + enddo + endif else jshift=1 if (segment%direction == OBC_DIRECTION_N) jshift=0 - do i=is_obc+1,ie_obc - J=js_obc + J=js_obc + if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then + ! Do q points for the whole segment + do I=max(is_obc,isd),min(ie_obc,ied-1) + segment%field(m)%buffer_dst(I,J,:)=0.0 ! initialize remap destination buffer + if (G%mask2dCv(i,J)>0. .and. G%mask2dCv(i+1,J)>0.) then ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here - segment%field(m)%buffer_dst(i,J,:)=0.0 ! initialize remap destination buffer - if (G%mask2dCv(i,J)>0.) then - 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,:), & - G%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) - endif - enddo + h_stack(:) = 0.5*(h(i,j+jshift,:) + 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,:), & + G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + 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,:), & + G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + 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,:), & + G%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + endif + enddo + else + do i=is_obc+1,ie_obc + ! Using the h remapping approach + ! Pretty sure we need to check for source/target grid consistency here + segment%field(m)%buffer_dst(i,J,:)=0.0 ! initialize remap destination buffer + if (G%mask2dCv(i,J)>0.) then + net_H_src = sum( segment%field(m)%dz_src(i,J,:) ) + net_H_int = sum( h(i,j+jshift,:) ) + scl_fac = net_H_int / net_H_src + 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,:), & + G%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) + endif + enddo + endif endif else ! 2d data segment%field(m)%buffer_dst(:,:,1)=segment%field(m)%buffer_src(:,:,1) ! initialize remap destination buffer endif deallocate(tmp_buffer) - else ! fid <= 0 - if (.not. ASSOCIATED(segment%field(m)%buffer_dst)) then - allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + else ! fid <= 0 (Uniform value) + if (.not. associated(segment%field(m)%buffer_dst)) then + if (segment%is_E_or_W) then + if (segment%field(m)%name == 'V') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) + elseif (segment%field(m)%name == 'U') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) + allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc+1:je_obc)) + elseif (segment%field(m)%name == 'DVDX') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + else + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc+1:je_obc,G%ke)) + endif + else + if (segment%field(m)%name == 'U') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) + elseif (segment%field(m)%name == 'V') then + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) + allocate(segment%field(m)%bt_vel(is_obc+1:ie_obc,js_obc:je_obc)) + elseif (segment%field(m)%name == 'DUDY') then + allocate(segment%field(m)%buffer_dst(is_obc:ie_obc,js_obc:je_obc,G%ke)) + else + allocate(segment%field(m)%buffer_dst(is_obc+1:ie_obc,js_obc:je_obc,G%ke)) + endif + endif segment%field(m)%buffer_dst(:,:,:)=segment%field(m)%value if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then - allocate(segment%field(m)%bt_vel(is_obc:ie_obc,js_obc:je_obc)) segment%field(m)%bt_vel(:,:)=segment%field(m)%value endif endif endif + if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then + if (segment%field(m)%fid>0) then ! calculate external BT velocity and transport if needed + if (trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) then + I=is_obc + do j=js_obc+1,je_obc + segment%normal_trans_bt(I,j) = 0.0 + do k=1,G%ke + segment%normal_vel(I,j,k) = segment%field(m)%buffer_dst(I,j,k) + segment%normal_trans(I,j,k) = segment%field(m)%buffer_dst(I,j,k)*segment%h(I,j,k) * & + G%dyCu(I,j) + segment%normal_trans_bt(I,j)= segment%normal_trans_bt(I,j)+segment%normal_trans(I,j,k) + enddo + segment%normal_vel_bt(I,j) = segment%normal_trans_bt(I,j)/(max(segment%Htot(I,j),1.e-12) * & + G%dyCu(I,j)) + if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(I,j,:) = segment%normal_vel(I,j,:) + enddo + elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S) then + J=js_obc + do i=is_obc+1,ie_obc + segment%normal_trans_bt(i,J) = 0.0 + do k=1,G%ke + segment%normal_vel(i,J,k) = segment%field(m)%buffer_dst(i,J,k) + segment%normal_trans(i,J,k) = segment%field(m)%buffer_dst(i,J,k)*segment%h(i,J,k) * & + G%dxCv(i,J) + segment%normal_trans_bt(i,J)= segment%normal_trans_bt(i,J)+segment%normal_trans(i,J,k) + enddo + segment%normal_vel_bt(i,J) = segment%normal_trans_bt(i,J)/(max(segment%Htot(i,J),1.e-12) * & + G%dxCv(i,J)) + if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,J,:) = segment%normal_vel(i,J,:) + enddo + elseif (trim(segment%field(m)%name) == 'V' .and. segment%is_E_or_W .and. & + associated(segment%tangential_vel)) then + I=is_obc + do J=js_obc,je_obc + do k=1,G%ke + segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + enddo + if (associated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + enddo + elseif (trim(segment%field(m)%name) == 'U' .and. segment%is_N_or_S .and. & + associated(segment%tangential_vel)) then + J=js_obc + do I=is_obc,ie_obc + do k=1,G%ke + segment%tangential_vel(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + enddo + if (associated(segment%nudged_tangential_vel)) & + segment%nudged_tangential_vel(I,J,:) = segment%tangential_vel(I,J,:) + enddo + elseif (trim(segment%field(m)%name) == 'DVDX' .and. segment%is_E_or_W .and. & + associated(segment%tangential_grad)) then + I=is_obc + do J=js_obc,je_obc + do k=1,G%ke + segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + enddo + enddo + elseif (trim(segment%field(m)%name) == 'DUDY' .and. segment%is_N_or_S .and. & + associated(segment%tangential_grad)) then + J=js_obc + do I=is_obc,ie_obc + do k=1,G%ke + segment%tangential_grad(I,J,k) = segment%field(m)%buffer_dst(I,J,k) + enddo + enddo + endif + endif + endif + ! from this point on, data are entirely on segments - will ! write all segment loops as 2d loops. if (segment%is_E_or_W) then @@ -2236,26 +2866,6 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) js_obc2 = js_obc+1 endif - if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then - if (segment%field(m)%fid>0) then ! calculate external BT velocity and transport if needed - if((trim(segment%field(m)%name) == 'U' .and. segment%is_E_or_W) .or. & - (trim(segment%field(m)%name) == 'V' .and. segment%is_N_or_S)) then - do j=js_obc2,je_obc - do i=is_obc2,ie_obc - segment%normal_trans_bt(i,j) = 0.0 - do k=1,G%ke - segment%normal_vel(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - segment%normal_trans(i,j,k) = segment%field(m)%buffer_dst(i,j,k)*segment%h(i,j,k) - segment%normal_trans_bt(i,j)= segment%normal_trans_bt(i,j)+segment%normal_trans(i,j,k) - enddo - segment%normal_vel_bt(i,j) = segment%normal_trans_bt(i,j)/max(segment%Htot(i,j),1.e-12) - if (associated(segment%nudged_normal_vel)) segment%nudged_normal_vel(i,j,:) = segment%normal_vel(i,j,:) - enddo - enddo - endif - endif - endif - if (trim(segment%field(m)%name) == 'SSH') then do j=js_obc2,je_obc do i=is_obc2,ie_obc @@ -2266,23 +2876,38 @@ subroutine update_OBC_segment_data(G, GV, OBC, tv, h, Time) if (trim(segment%field(m)%name) == 'TEMP') then if (associated(segment%field(m)%buffer_dst)) then - do k=1,nz; do j=js_obc2, je_obc;do i=is_obc2,ie_obc + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(1)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo + if (.not. segment%tr_Reg%Tr(1)%is_initialized) then + ! if the tracer reservoir has not yet been initialized, then set to external value. + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(1)%tres(i,j,k) = segment%tr_Reg%Tr(1)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(1)%is_initialized=.true. + endif else segment%tr_Reg%Tr(1)%OBC_inflow_conc = segment%field(m)%value endif elseif (trim(segment%field(m)%name) == 'SALT') then if (associated(segment%field(m)%buffer_dst)) then - do k=1,nz; do j=js_obc2, je_obc;do i=is_obc2,ie_obc + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc segment%tr_Reg%Tr(2)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) - enddo; enddo; enddo + enddo ; enddo ; enddo + if (.not. segment%tr_Reg%Tr(1)%is_initialized) then + !if the tracer reservoir has not yet been initialized, then set to external value. + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(2)%tres(i,j,k) = segment%tr_Reg%Tr(2)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(1)%is_initialized=.true. + endif else segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value endif endif - enddo + enddo ! end field loop + deallocate(h_stack) enddo ! end segment loop @@ -2402,21 +3027,22 @@ subroutine segment_tracer_registry_init(param_file, segment) end subroutine segment_tracer_registry_init -subroutine register_segment_tracer(tr_desc, param_file, GV, segment, tr_desc_ptr, & +subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & OBC_scalar, OBC_array) - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(vardesc), intent(in) :: tr_desc !< metadata about the tracer - type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values - type(OBC_segment_type), intent(inout) :: segment !< current segment data structure - type(vardesc), target, optional :: tr_desc_ptr !< A target that can be used to set a pointer to the - !! stored value of tr%tr_desc. This target must be - !! an enduring part of the control structure, - !! because the tracer registry will use this memory, - !! but it also means that any updates to this - !! structure in the calling module will be - !! available subsequently to the tracer registry. - real, optional :: OBC_scalar !< If present, use scalar value for segment tracer inflow concentration. - logical, optional :: OBC_array !< If true, use array values for segment tracer inflow concentration. + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(tracer_type), target :: tr_ptr !< A target that can be used to set a pointer to the + !! stored value of tr. This target must be + !! an enduring part of the control structure, + !! because the tracer registry will use this memory, + !! but it also means that any updates to this + !! structure in the calling module will be + !! available subsequently to the tracer registry. + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + type(OBC_segment_type), intent(inout) :: segment !< current segment data structure + real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer + !! inflow concentration. + logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer + !! inflow concentration. ! Local variables @@ -2425,7 +3051,6 @@ subroutine register_segment_tracer(tr_desc, param_file, GV, segment, tr_desc_ptr integer :: IsdB, IedB, JsdB, JedB character(len=256) :: mesg ! Message for error messages. -! if (.not. associated(segment%tr_Reg)) call segment_tracer_registry_init(param_file, segment) call segment_tracer_registry_init(param_file, segment) if (segment%tr_Reg%ntseg>=MAX_FIELDS_) then @@ -2441,13 +3066,8 @@ subroutine register_segment_tracer(tr_desc, param_file, GV, segment, tr_desc_ptr IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - if (present(tr_desc_ptr)) then - segment%tr_Reg%Tr(ntseg)%vd => tr_desc_ptr - else - allocate(segment%tr_Reg%Tr(ntseg)%vd) ; segment%tr_Reg%Tr(ntseg)%vd = tr_desc - endif - - call query_vardesc(segment%tr_Reg%Tr(ntseg)%vd, name=segment%tr_Reg%Tr(ntseg)%name) + segment%tr_Reg%Tr(ntseg)%Tr => tr_ptr + segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name if (segment%tr_Reg%locked) call MOM_error(FATAL, & "MOM register_tracer was called for variable "//trim(segment%tr_Reg%Tr(ntseg)%name)//& @@ -2456,9 +3076,13 @@ subroutine register_segment_tracer(tr_desc, param_file, GV, segment, tr_desc_ptr if (present(OBC_scalar)) segment%tr_Reg%Tr(ntseg)%OBC_inflow_conc = OBC_scalar ! initialize tracer value later if (present(OBC_array)) then if (segment%is_E_or_W) then - allocate(segment%tr_Reg%Tr(ntseg)%t(IsdB:IedB,jsd:jed,1:GV%ke)) + allocate(segment%tr_Reg%Tr(ntseg)%t(IsdB:IedB,jsd:jed,1:GV%ke));segment%tr_Reg%Tr(ntseg)%t(:,:,:)=0.0 + allocate(segment%tr_Reg%Tr(ntseg)%tres(IsdB:IedB,jsd:jed,1:GV%ke));segment%tr_Reg%Tr(ntseg)%tres(:,:,:)=0.0 + segment%tr_Reg%Tr(ntseg)%is_initialized=.false. elseif (segment%is_N_or_S) then - allocate(segment%tr_Reg%Tr(ntseg)%t(isd:ied,JsdB:JedB,1:GV%ke)) + allocate(segment%tr_Reg%Tr(ntseg)%t(isd:ied,JsdB:JedB,1:GV%ke));segment%tr_Reg%Tr(ntseg)%t(:,:,:)=0.0 + allocate(segment%tr_Reg%Tr(ntseg)%tres(isd:ied,JsdB:JedB,1:GV%ke));segment%tr_Reg%Tr(ntseg)%tres(:,:,:)=0.0 + segment%tr_Reg%Tr(ntseg)%is_initialized=.false. endif endif @@ -2479,18 +3103,18 @@ subroutine segment_tracer_registry_end(Reg) endif end subroutine segment_tracer_registry_end -subroutine register_temp_salt_segments(GV, OBC, tv, vd_T, vd_S, param_file) +subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - type(vardesc), intent(in) :: vd_T !< Temperature descriptor - type(vardesc), intent(in) :: vd_S !< Salinity descriptor + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry 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 type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + type(tracer_type), pointer :: tr_ptr if (.not. associated(OBC)) return @@ -2501,9 +3125,13 @@ subroutine register_temp_salt_segments(GV, OBC, tv, vd_T, vd_S, param_file) if (associated(segment%tr_Reg)) & call MOM_error(FATAL,"register_temp_salt_segments: tracer array was previously allocated") - call register_segment_tracer(vd_T, param_file, GV, segment, & + name = 'temp' + call tracer_name_lookup(tr_Reg, tr_ptr, name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, & OBC_array=segment%temp_segment_data_exists) - call register_segment_tracer(vd_S, param_file, GV, segment, & + name = 'salt' + call tracer_name_lookup(tr_Reg, tr_ptr, name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, & OBC_array=segment%salt_segment_data_exists) enddo @@ -2561,6 +3189,8 @@ subroutine fill_temp_salt_segments(G, OBC, tv) endif enddo ; enddo endif + segment%tr_Reg%Tr(1)%tres(:,:,:) = segment%tr_Reg%Tr(1)%t(:,:,:) + segment%tr_Reg%Tr(2)%tres(:,:,:) = segment%tr_Reg%Tr(2)%t(:,:,:) enddo end subroutine fill_temp_salt_segments @@ -2575,8 +3205,10 @@ subroutine mask_outside_OBCs(G, param_file, OBC) ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j + logical :: fatal_error = .False. real :: min_depth integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 + character(len=256) :: mesg ! Message for error messages. type(OBC_segment_type), pointer :: segment ! pointer to segment type list real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside, ! two different ways @@ -2657,10 +3289,16 @@ subroutine mask_outside_OBCs(G, param_file, OBC) ! Use the color to set outside to min_depth on this process. do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (color(i,j) /= color2(i,j)) call MOM_error(FATAL, & - "MOM_open_boundary: inconsistent OBC segments.") + 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 + call MOM_error(WARNING,"MOM register_tracer: "//mesg, all_print=.true.) + endif if (color(i,j) == cout) G%bathyT(i,j) = min_depth enddo ; enddo + if (fatal_error) call MOM_error(FATAL, & + "MOM_open_boundary: inconsistent OBC segments.") deallocate(color) deallocate(color2) @@ -2788,10 +3426,10 @@ end subroutine flood_fill2 !> Register OBC segment data for restarts subroutine open_boundary_register_restarts(HI, GV, OBC_CS,restart_CSp) - type(hor_index_type), intent(in) :: HI !< Horizontal indices - type(verticalGrid_type), pointer, intent(in) :: GV !< Container for vertical grid information - type(ocean_OBC_type), pointer, intent(inout) :: OBC_CS !< OBC data structure - type(MOM_restart_CS), pointer, intent(inout) :: restart_CSp !< Restart structure + type(hor_index_type), intent(in) :: HI !< Horizontal indices + type(verticalGrid_type), pointer :: GV !< Container for vertical grid information + type(ocean_OBC_type), pointer :: OBC_CS !< OBC data structure, data intent(inout) + type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) ! Local variables type(vardesc) :: vd @@ -2807,7 +3445,7 @@ subroutine open_boundary_register_restarts(HI, GV, OBC_CS,restart_CSp) ! 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. *** - if (OBC_CS%radiation_BCs_exist_globally) then + if (OBC_CS%radiation_BCs_exist_globally .or. OBC_CS%oblique_BCs_exist_globally) then allocate(OBC_CS%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke)) OBC_CS%rx_normal(:,:,:) = 0.0 vd = var_desc("rx_normal","m s-1", "Normal Phase Speed for EW OBCs",'u','L') diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90 index b6255dfaef..75892d19f3 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -63,7 +63,6 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG) oG%dxCu(I,j) = dG%dxCu(I+ido,j+jdo) oG%dyCu(I,j) = dG%dyCu(I+ido,j+jdo) oG%dy_Cu(I,j) = dG%dy_Cu(I+ido,j+jdo) - oG%dy_Cu_obc(I,j) = dG%dy_Cu_obc(I+ido,j+jdo) oG%mask2dCu(I,j) = dG%mask2dCu(I+ido,j+jdo) oG%areaCu(I,j) = dG%areaCu(I+ido,j+jdo) @@ -76,7 +75,6 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG) oG%dxCv(i,J) = dG%dxCv(i+ido,J+jdo) oG%dyCv(i,J) = dG%dyCv(i+ido,J+jdo) oG%dx_Cv(i,J) = dG%dx_Cv(i+ido,J+jdo) - oG%dx_Cv_obc(i,J) = dG%dx_Cv_obc(i+ido,J+jdo) oG%mask2dCv(i,J) = dG%mask2dCv(i+ido,J+jdo) oG%areaCv(i,J) = dG%areaCv(i+ido,J+jdo) @@ -137,7 +135,6 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG) call pass_vector(oG%dyCu, oG%dxCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%dxCu, oG%dyCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%dy_Cu, oG%dx_Cv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) - call pass_vector(oG%dy_Cu_obc, oG%dx_Cv_obc, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%mask2dCu, oG%mask2dCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%IareaCu, oG%IareaCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(oG%IareaCu, oG%IareaCv, oG%Domain, To_All+Scalar_Pair, CGRID_NE) @@ -209,7 +206,6 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG) dG%dxCu(I,j) = oG%dxCu(I+ido,j+jdo) dG%dyCu(I,j) = oG%dyCu(I+ido,j+jdo) dG%dy_Cu(I,j) = oG%dy_Cu(I+ido,j+jdo) - dG%dy_Cu_obc(I,j) = oG%dy_Cu_obc(I+ido,j+jdo) dG%mask2dCu(I,j) = oG%mask2dCu(I+ido,j+jdo) dG%areaCu(I,j) = oG%areaCu(I+ido,j+jdo) @@ -222,7 +218,6 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG) dG%dxCv(i,J) = oG%dxCv(i+ido,J+jdo) dG%dyCv(i,J) = oG%dyCv(i+ido,J+jdo) dG%dx_Cv(i,J) = oG%dx_Cv(i+ido,J+jdo) - dG%dx_Cv_obc(i,J) = oG%dx_Cv_obc(i+ido,J+jdo) dG%mask2dCv(i,J) = oG%mask2dCv(i+ido,J+jdo) dG%areaCv(i,J) = oG%areaCv(i+ido,J+jdo) @@ -284,7 +279,6 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG) call pass_vector(dG%dyCu, dG%dxCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%dxCu, dG%dyCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%dy_Cu, dG%dx_Cv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) - call pass_vector(dG%dy_Cu_obc, dG%dx_Cv_obc, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%mask2dCu, dG%mask2dCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%IareaCu, dG%IareaCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) call pass_vector(dG%IareaCu, dG%IareaCv, dG%Domain, To_All+Scalar_Pair, CGRID_NE) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index f3bd5fb76d..ff5a93a62c 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -10,6 +10,10 @@ module MOM_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_diag_vkernels, only : diag_vkernels_unit_tests +implicit none ; private + +public unit_tests + contains !> Calls unit tests for other modules. diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index f7fa45f12c..02b0b622a3 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -233,6 +233,9 @@ module MOM_variables !! convection etc). TKE_turb => NULL() !< The turbulent kinetic energy per unit mass defined !! at the interfaces between each layer, in m2 s-2. + logical :: add_Kv_slow !< If True, adds Kv_slow when calculating the + !! 'coupling coefficient' (a[k]) at the interfaces. + !! This is done in find_coupling_coef. end type vertvisc_type !> The BT_cont_type structure contains information about the summed layer @@ -281,7 +284,8 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. - logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically integrated fields. + logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically + !! integrated fields. type(coupler_1d_bc_type), & optional, intent(in) :: gas_fields_ocn !< If present, this type describes the ocean !! ocean and surface-ice fields that will participate @@ -359,9 +363,10 @@ end subroutine deallocate_surface_state !> alloc_BT_cont_type allocates the arrays contained within a BT_cont_type and !! initializes them to 0. subroutine alloc_BT_cont_type(BT_cont, G, alloc_faces) - type(BT_cont_type), pointer :: BT_cont + type(BT_cont_type), pointer :: BT_cont !< The BT_cont_type whose elements will be allocated type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - logical, optional, intent(in) :: alloc_faces + logical, optional, intent(in) :: alloc_faces !< If present and true, allocate + !! memory for effective face thicknesses. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -416,33 +421,23 @@ end subroutine dealloc_BT_cont_type !> MOM_thermovar_chksum does diagnostic checksums on various elements of a !! thermo_var_ptrs type for debugging. subroutine MOM_thermovar_chksum(mesg, tv, G) - character(len=*), intent(in) :: mesg - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! This subroutine writes out chksums for the model's basic state variables. -! Arguments: mesg - A message that appears on the chksum lines. -! (in) u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m. -! (in) uh - Volume flux through zonal faces = u*h*dy, m3 s-1. -! (in) vh - Volume flux through meridional faces = v*h*dx, in m3 s-1. -! (in) G - The ocean's grid structure. - integer :: is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + character(len=*), intent(in) :: mesg !< A message that appears in the checksum lines + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure ! Note that for the chksum calls to be useful for reproducing across PE ! counts, there must be no redundant points, so all variables use is..ie ! and js...je as their extent. if (associated(tv%T)) & - call hchksum(tv%T, mesg//" tv%T",G%HI) + call hchksum(tv%T, mesg//" tv%T", G%HI) if (associated(tv%S)) & - call hchksum(tv%S, mesg//" tv%S",G%HI) + call hchksum(tv%S, mesg//" tv%S", G%HI) if (associated(tv%frazil)) & - call hchksum(tv%frazil, mesg//" tv%frazil",G%HI) + call hchksum(tv%frazil, mesg//" tv%frazil", G%HI) if (associated(tv%salt_deficit)) & - call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit",G%HI) + call hchksum(tv%salt_deficit, mesg//" tv%salt_deficit", G%HI) if (associated(tv%TempxPmE)) & - call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE",G%HI) + call hchksum(tv%TempxPmE, mesg//" tv%TempxPmE", G%HI) end subroutine MOM_thermovar_chksum end module MOM_variables diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index a57bd1f61f..c03a811400 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -16,50 +16,50 @@ module MOM_verticalGrid type, public :: verticalGrid_type ! Commonly used parameters - integer :: ke ! The number of layers/levels in the vertical - real :: max_depth ! The maximum depth of the ocean in meters. - real :: g_Earth ! The gravitational acceleration in m s-2. - real :: Rho0 ! The density used in the Boussinesq approximation or - ! nominal density used to convert depths into mass - ! units, in kg m-3. + integer :: ke !< The number of layers/levels in the vertical + real :: max_depth !< The maximum depth of the ocean in meters. + real :: g_Earth !< The gravitational acceleration in m s-2. + real :: Rho0 !< The density used in the Boussinesq approximation or + !! nominal density used to convert depths into mass + !! units, in kg m-3. ! Vertical coordinate descriptions for diagnostics and I/O character(len=40) :: & - zAxisUnits, & ! The units that vertical coordinates are written in - zAxisLongName ! Coordinate name to appear in files, - ! e.g. "Target Potential Density" or "Height" - real ALLOCABLE_, dimension(NKMEM_) :: sLayer ! Coordinate values of layer centers - real ALLOCABLE_, dimension(NK_INTERFACE_) :: sInterface ! Coordinate values on interfaces - integer :: direction = 1 ! Direction defaults to 1, positive up. + zAxisUnits, & !< The units that vertical coordinates are written in + zAxisLongName !< Coordinate name to appear in files, + !! e.g. "Target Potential Density" or "Height" + real ALLOCABLE_, dimension(NKMEM_) :: sLayer !< Coordinate values of layer centers + real ALLOCABLE_, dimension(NK_INTERFACE_) :: sInterface !< Coordinate values on interfaces + integer :: direction = 1 !< Direction defaults to 1, positive up. ! The following variables give information about the vertical grid. - logical :: Boussinesq ! If true, make the Boussinesq approximation. - real :: Angstrom ! A one-Angstrom thickness in the model's thickness - ! units. (This replaces the old macro EPSILON.) - real :: Angstrom_z ! A one-Angstrom thickness in m. - real :: H_subroundoff ! A thickness that is so small that it can be added to - ! a thickness of Angstrom or larger without changing it - ! at the bit level, in thickness units. If Angstrom is - ! 0 or exceedingly small, this is negligible compared to - ! a thickness of 1e-17 m. + logical :: Boussinesq !< If true, make the Boussinesq approximation. + real :: Angstrom !< A one-Angstrom thickness in the model's thickness + !! units. (This replaces the old macro EPSILON.) + real :: Angstrom_z !< A one-Angstrom thickness in m. + real :: H_subroundoff !< A thickness that is so small that it can be added to + !! a thickness of Angstrom or larger without changing it + !! at the bit level, in thickness units. If Angstrom is + !! 0 or exceedingly small, this is negligible compared to + !! a thickness of 1e-17 m. real ALLOCABLE_, dimension(NK_INTERFACE_) :: & - g_prime, & ! The reduced gravity at each interface, in m s-2. - Rlay ! The target coordinate value (potential density) in - ! in each layer in kg m-3. - integer :: nkml = 0 ! The number of layers at the top that should be treated - ! as parts of a homogenous region. - integer :: nk_rho_varies = 0 ! The number of layers at the top where the - ! density does not track any target density. - real :: H_to_kg_m2 ! A constant that translates thicknesses from the units - ! of thickness to kg m-2. - real :: kg_m2_to_H ! A constant that translates thicknesses from kg m-2 to - ! the units of thickness. - real :: m_to_H ! A constant that translates distances in m to the - ! units of thickness. - real :: H_to_m ! A constant that translates distances in the units of - ! thickness to m. - real :: H_to_Pa ! A constant that translates the units of thickness to - ! to pressure in Pa. + g_prime, & !< The reduced gravity at each interface, in m s-2. + Rlay !< The target coordinate value (potential density) in + !! in each layer in kg m-3. + integer :: nkml = 0 !< The number of layers at the top that should be treated + !! as parts of a homogenous region. + integer :: nk_rho_varies = 0 !< The number of layers at the top where the + !! density does not track any target density. + real :: H_to_kg_m2 !< A constant that translates thicknesses from the units + !! of thickness to kg m-2. + real :: kg_m2_to_H !< A constant that translates thicknesses from kg m-2 to + !! the units of thickness. + real :: m_to_H !< A constant that translates distances in m to the + !! units of thickness. + real :: H_to_m !< A constant that translates distances in the units of + !! thickness to m. + real :: H_to_Pa !< A constant that translates the units of thickness to + !! to pressure in Pa. end type verticalGrid_type contains @@ -68,8 +68,8 @@ module MOM_verticalGrid subroutine verticalGridInit( param_file, GV ) ! This routine initializes the verticalGrid_type structure (GV). ! All memory is allocated but not necessarily set to meaningful values until later. - type(param_file_type), intent(in) :: param_file ! Parameter file handle/type - type(verticalGrid_type), pointer :: GV ! The container for vertical grid data + type(param_file_type), intent(in) :: param_file !< Parameter file handle/type + type(verticalGrid_type), pointer :: GV !< The container for vertical grid data ! This include declares and sets the variable "version". #include "version_variable.h" integer :: nk, H_power diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index fee8e0ab0a..10845e8cfa 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -78,11 +78,9 @@ module MOM_PointAccel !> This subroutine writes to an output file all of the accelerations !! that have been applied to a column of zonal velocities over the !! previous timestep. This subroutine is called from vertvisc. -subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & - maxvel, minvel, str, a, hv) +subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, vel_rpt, str, a, hv) integer, intent(in) :: I !< The zonal index of the column to be documented. - integer, intent(in) :: j !< The meridional index of the column to be - !! documented. + integer, intent(in) :: j !< The meridional index of the column to be documented. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & @@ -96,13 +94,12 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & real, intent(in) :: dt !< The ocean dynamics time step, in s. type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous !! call to PointAccel_init. - real, intent(in) :: maxvel, minvel + real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report, in m s-1. real, optional, intent(in) :: str !< The surface wind stress integrated over a time !! step, in m2 s-1. - real, dimension(SZIB_(G),SZK_(G)), & - optional, intent(in) :: a !< The layer coupling coefficients from - !! vertvisc, m. - real, dimension(SZIB_(G),SZK_(G)), & + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc, m. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc, in m. @@ -110,25 +107,6 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & ! that have been applied to a column of zonal velocities over the ! previous timestep. This subroutine is called from vertvisc. -! Arguments: I - The zonal index of the column to be documented. -! (in) j - The meridional index of the column to be documented. -! (in) um - The new zonal velocity, in m s-1. -! (in) hin - The layer thickness, in m. -! (in) ADp - A structure pointing to the various accelerations in -! the momentum equations. -! (in) CDp - A structure with pointers to various terms in the continuity -! equations. -! (in) dt - The model's dynamics time step. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! PointAccel_init. -! (in) str - The surface wind stress integrated over a time -! step, in m2 s-1. -! (in) a - The layer coupling coefficients from vertvisc, m. -! (in) hv - The layer thicknesses at velocity grid points, from -! vertvisc, in m. - real :: f_eff, CFL real :: Angstrom real :: truncvel, du @@ -167,14 +145,14 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & ! Determine which layers to write out accelerations for. do k=1,nz - if (((max(CS%u_av(I,j,k),um(I,j,k)) >= maxvel) .or. & - (min(CS%u_av(I,j,k),um(I,j,k)) <= minvel)) .and. & + if (((max(CS%u_av(I,j,k),um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k),um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(CS%u_av(I,j,k), um(I,j,k)) >= maxvel) .or. & - (min(CS%u_av(I,j,k), um(I,j,k)) <= minvel)) .and. & + if (((max(CS%u_av(I,j,k), um(I,j,k)) >= vel_rpt) .or. & + (min(CS%u_av(I,j,k), um(I,j,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -229,17 +207,17 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & write(file,'(/,"diffu: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (dt*ADp%diffu(I,j,k)); enddo - if (ASSOCIATED(ADp%gradKEu)) then + if (associated(ADp%gradKEu)) then write(file,'(/,"KEu: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (dt*ADp%gradKEu(I,j,k)); enddo endif - if (ASSOCIATED(ADp%rv_x_v)) then + if (associated(ADp%rv_x_v)) then write(file,'(/,"Coru: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)); enddo endif - if (ASSOCIATED(ADp%du_dt_visc)) then + if (associated(ADp%du_dt_visc)) then write(file,'(/,"ubv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (um(I,j,k)-dt*ADp%du_dt_visc(I,j,k)); enddo @@ -247,22 +225,22 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (dt*ADp%du_dt_visc(I,j,k)); enddo endif - if (ASSOCIATED(ADp%du_other)) then + if (associated(ADp%du_other)) then write(file,'(/,"du_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (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," ",$)') a(I,k); enddo + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(I,j,k); enddo endif if (present(hv)) then write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(I,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(I,j,k); enddo endif write(file,'(/,"Stress: ",ES10.3)') str - if (ASSOCIATED(CS%u_accel_bt)) then + if (associated(CS%u_accel_bt)) then write(file,'("dubt: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (dt*CS%u_accel_bt(I,j,k)) ; enddo @@ -294,13 +272,13 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & 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 - if (ASSOCIATED(CS%T)) then + 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 endif - if (ASSOCIATED(CS%S)) then + 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+: ",$)') @@ -395,27 +373,27 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, CS, & do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (dt*ADp%diffu(I,j,k)*Inorm(k)); enddo - if (ASSOCIATED(ADp%gradKEu)) then + if (associated(ADp%gradKEu)) then write(file,'(/,"KEu: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (dt*ADp%gradKEu(I,j,k)*Inorm(k)); enddo endif - if (ASSOCIATED(ADp%rv_x_v)) then + if (associated(ADp%rv_x_v)) then write(file,'(/,"Coru: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k))*Inorm(k); enddo endif - if (ASSOCIATED(ADp%du_dt_visc)) then + if (associated(ADp%du_dt_visc)) then write(file,'(/,"duv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (dt*ADp%du_dt_visc(I,j,k))*Inorm(k); enddo endif - if (ASSOCIATED(ADp%du_other)) then + if (associated(ADp%du_other)) then write(file,'(/,"du_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (ADp%du_other(I,j,k))*Inorm(k); enddo endif - if (ASSOCIATED(CS%u_accel_bt)) then + if (associated(CS%u_accel_bt)) then write(file,'(/,"dubt: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (dt*CS%u_accel_bt(I,j,k)*Inorm(k)) ; enddo @@ -432,11 +410,9 @@ end subroutine write_u_accel !> This subroutine writes to an output file all of the accelerations !! that have been applied to a column of meridional velocities over !! the previous timestep. This subroutine is called from vertvisc. -subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & - maxvel, minvel, str, a, hv) +subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, vel_rpt, str, a, hv) integer, intent(in) :: i !< The zonal index of the column to be documented. - integer, intent(in) :: J !< The meridional index of the column to be - !! documented. + integer, intent(in) :: J !< The meridional index of the column to be documented. 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),SZJB_(G),SZK_(G)), & @@ -450,13 +426,12 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & real, intent(in) :: dt !< The ocean dynamics time step, in s. type(PointAccel_CS), pointer :: CS !< The control structure returned by a previous !! call to PointAccel_init. - real, intent(in) :: maxvel, minvel + real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report, in m s-1. real, optional, intent(in) :: str !< The surface wind stress integrated over a time !! step, in m2 s-1. - real, dimension(SZI_(G),SZK_(G)), & - optional, intent(in) :: a !< The layer coupling coefficients from - !! vertvisc, m. - real, dimension(SZI_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc, m. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc, in m. @@ -520,14 +495,14 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & prev_avail = (associated(CS%u_prev) .and. associated(CS%v_prev)) do k=1,nz - if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= maxvel) .or. & - (min(CS%v_av(i,J,k), vm(i,J,k)) <= minvel)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ks = k do k=nz,1,-1 - if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= maxvel) .or. & - (min(CS%v_av(i,J,k), vm(i,J,k)) <= minvel)) .and. & + if (((max(CS%v_av(i,J,k), vm(i,J,k)) >= vel_rpt) .or. & + (min(CS%v_av(i,J,k), vm(i,J,k)) <= -vel_rpt)) .and. & ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom)) exit enddo ke = k @@ -586,17 +561,17 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & write(file,'(/,"diffv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (dt*ADp%diffv(i,J,k)); enddo - if (ASSOCIATED(ADp%gradKEv)) then + if (associated(ADp%gradKEv)) then write(file,'(/,"KEv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (dt*ADp%gradKEv(i,J,k)); enddo endif - if (ASSOCIATED(ADp%rv_x_u)) then + if (associated(ADp%rv_x_u)) then write(file,'(/,"Corv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)); enddo endif - if (ASSOCIATED(ADp%dv_dt_visc)) then + if (associated(ADp%dv_dt_visc)) then write(file,'(/,"vbv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (vm(i,J,k)-dt*ADp%dv_dt_visc(i,J,k)); enddo @@ -605,22 +580,22 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (dt*ADp%dv_dt_visc(i,J,k)); enddo endif - if (ASSOCIATED(ADp%dv_other)) then + if (associated(ADp%dv_other)) then write(file,'(/,"dv_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (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," ",$)') a(i,k); enddo + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') a(i,j,k); enddo endif if (present(hv)) then write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(i,k); enddo + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') hv(i,J,k); enddo endif write(file,'(/,"Stress: ",ES10.3)') str - if (ASSOCIATED(CS%v_accel_bt)) then + if (associated(CS%v_accel_bt)) then write(file,'("dvbt: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & (dt*CS%v_accel_bt(i,J,k)) ; enddo @@ -651,13 +626,13 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & 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 - if (ASSOCIATED(CS%T)) then + 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 endif - if (ASSOCIATED(CS%S)) then + 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+: ",$)') @@ -748,27 +723,27 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, CS, & do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (dt*ADp%diffv(i,J,k)*Inorm(k)); enddo - if (ASSOCIATED(ADp%gradKEu)) then + if (associated(ADp%gradKEu)) then write(file,'(/,"KEv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (dt*ADp%gradKEv(i,J,k)*Inorm(k)); enddo endif - if (ASSOCIATED(ADp%rv_x_u)) then + if (associated(ADp%rv_x_u)) then write(file,'(/,"Corv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k))*Inorm(k); enddo endif - if (ASSOCIATED(ADp%dv_dt_visc)) then + if (associated(ADp%dv_dt_visc)) then write(file,'(/,"dvv: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (dt*ADp%dv_dt_visc(i,J,k)*Inorm(k)); enddo endif - if (ASSOCIATED(ADp%dv_other)) then + if (associated(ADp%dv_other)) then write(file,'(/,"dv_other: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (ADp%dv_other(i,J,k)*Inorm(k)); enddo endif - if (ASSOCIATED(CS%v_accel_bt)) then + if (associated(CS%v_accel_bt)) then write(file,'(/,"dvbt: ",$)') do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & (dt*CS%v_accel_bt(i,J,k)*Inorm(k)) ; enddo @@ -830,15 +805,15 @@ subroutine PointAccel_init(MIS, Time, G, param_file, diag, dirs, CS) "The absolute path to the file where the accelerations \n"//& "leading to zonal velocity truncations are written. \n"//& "Leave this empty for efficiency if this diagnostic is \n"//& - "not needed.", default="") + "not needed.", default="", debuggingParam=.true.) call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & "The absolute path to the file where the accelerations \n"//& "leading to meridional velocity truncations are written. \n"//& "Leave this empty for efficiency if this diagnostic is \n"//& - "not needed.", default="") + "not needed.", default="", debuggingParam=.true.) call get_param(param_file, mdl, "MAX_TRUNC_FILE_SIZE_PER_PE", CS%max_writes, & "The maximum number of colums of truncations that any PE \n"//& - "will write out during a run.", default=50) + "will write out during a run.", default=50, debuggingParam=.true.) if (len_trim(dirs%output_directory) > 0) then if (len_trim(CS%u_trunc_file) > 0) & diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 8493ea27b6..53105609ca 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -79,13 +79,16 @@ subroutine MOM_debugging_init(param_file) call log_version(param_file, mdl, version) call get_param(param_file, mdl, "DEBUG", debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_CHKSUMS", debug_chksums, & "If true, checksums are performed on arrays in the \n"//& - "various vec_chksum routines.", default=debug) + "various vec_chksum routines.", default=debug, & + debuggingParam=.true.) call get_param(param_file, mdl, "DEBUG_REDUNDANT", debug_redundant, & "If true, debug redundant data points during calls to \n"//& - "the various vec_chksum routines.", default=debug) + "the various vec_chksum routines.", default=debug, & + debuggingParam=.true.) call MOM_checksums_init(param_file) @@ -93,12 +96,18 @@ end subroutine MOM_debugging_init subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp - real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -122,12 +131,18 @@ end subroutine check_redundant_vC3d subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp - real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -196,10 +211,13 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vC2d subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -221,10 +239,13 @@ end subroutine check_redundant_sB3d subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -281,12 +302,18 @@ end subroutine check_redundant_sB2d subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -310,12 +337,18 @@ end subroutine check_redundant_vB3d subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -385,10 +418,13 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vB2d subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -410,10 +446,13 @@ end subroutine check_redundant_sT3d subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -456,12 +495,18 @@ end subroutine check_redundant_sT2d subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp - real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -485,12 +530,18 @@ end subroutine check_redundant_vT3d subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp - real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + character(len=*), intent(in) :: mesg !< An identifying message + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector + !! to be checked for consistency + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector + !! to be checked for consistency + integer, optional, intent(in) :: is !< The starting i-index to check + integer, optional, intent(in) :: ie !< The ending i-index to check + integer, optional, intent(in) :: js !< The starting j-index to check + integer, optional, intent(in) :: je !< The ending j-index to check + integer, optional, intent(in) :: direction !< the direction flag to be + !! passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -556,7 +607,7 @@ subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -582,7 +633,7 @@ subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -608,7 +659,7 @@ subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -635,9 +686,9 @@ subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric) real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical, optional, intent(in) :: symmetric !< If true, do the checksums on the - !! full symmetric computational domain. + !! full symmetric computational domain. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -664,7 +715,7 @@ subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars @@ -692,7 +743,7 @@ subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars) real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of - !! scalars that are being checked. + !! scalars that are being checked. logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars diff --git a/src/diagnostics/MOM_diag_to_Z.F90 b/src/diagnostics/MOM_diag_to_Z.F90 index 43f39c4e16..4efed0628f 100644 --- a/src/diagnostics/MOM_diag_to_Z.F90 +++ b/src/diagnostics/MOM_diag_to_Z.F90 @@ -106,7 +106,7 @@ function global_z_mean(var,G,CS,tracer) real, dimension(CS%nk_zspace) :: global_z_mean, scalarij, weightij real, dimension(CS%nk_zspace) :: global_temp_scalar, global_weight_scalar integer :: i, j, k, is, ie, js, je, nz, tracer - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec nz = CS%nk_zspace ! Initialize local arrays @@ -1153,7 +1153,7 @@ subroutine get_Z_depths(depth_file, int_depth_name, int_depth, cell_depth_name, nk_out = -1 - status = NF90_OPEN(depth_file, NF90_NOWRITE, ncid); + status = NF90_OPEN(depth_file, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& " Difficulties opening "//trim(depth_file)//" - "//& @@ -1257,9 +1257,9 @@ subroutine MOM_diag_to_Z_end(CS) type(diag_to_Z_CS), pointer :: CS integer :: m - if (ASSOCIATED(CS%u_z)) deallocate(CS%u_z) - if (ASSOCIATED(CS%v_z)) deallocate(CS%v_z) - if (ASSOCIATED(CS%Z_int)) deallocate(CS%Z_int) + if (associated(CS%u_z)) deallocate(CS%u_z) + if (associated(CS%v_z)) deallocate(CS%v_z) + if (associated(CS%Z_int)) deallocate(CS%Z_int) do m=1,CS%num_tr_used ; deallocate(CS%tr_z(m)%p) ; enddo deallocate(CS) @@ -1302,7 +1302,7 @@ function ocean_register_diag_with_z(tr_ptr, vardesc_tr, G, Time, CS) ! register the layer tracer ocean_register_diag_with_z = ocean_register_diag(vardesc_tr, G, CS%diag, Time) - ! copy layer tracer variable descriptor to a z-tracer descriptor; + ! copy layer tracer variable descriptor to a z-tracer descriptor ! change the name and layer information. vardesc_z = vardesc_tr call modify_vardesc(vardesc_z, z_grid="z", caller="ocean_register_diag_with_z") diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 1ea31011cb..b0d5d803e4 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -39,7 +39,6 @@ module MOM_diagnostics use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta use MOM_spatial_means, only : global_area_mean, global_layer_mean @@ -57,13 +56,14 @@ module MOM_diagnostics public calculate_diagnostic_fields, register_time_deriv, write_static_fields public find_eta -public MOM_diagnostics_init, MOM_diagnostics_end -public register_surface_diags, post_surface_diagnostics +public register_surface_diags, post_surface_dyn_diags, post_surface_thermo_diags public register_transport_diags, post_transport_diagnostics +public MOM_diagnostics_init, MOM_diagnostics_end type, public :: diagnostics_CS ; private real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as - !! monotonic for the purposes of calculating the equivalent barotropic wave speed. + !! monotonic for the purposes of calculating the equivalent + !! barotropic wave speed. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of !! calculating the equivalent barotropic wave speed. (m) @@ -189,43 +189,38 @@ module MOM_diagnostics contains !> Diagnostics not more naturally calculated elsewhere are computed here. -subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & +subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & dt, diag_pre_sync, G, GV, CS, eta_bt) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, - !! in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uh !< Transport through zonal faces - !! = u*h*dy, m3/s(Bouss) - !! kg/s(non-Bouss). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vh !< transport through meridional - !! faces = v*h*dx, m3/s(Bouss) - !! kg/s(non-Bouss). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to - !! various thermodynamic - !! variables. - type(accel_diag_ptrs), intent(in) :: ADp !< structure with pointers to - !! accelerations in momentum - !! equation. - type(cont_diag_ptrs), intent(in) :: CDp !< structure with pointers to - !! terms in continuity equation. - type(forcing), intent(in) :: fluxes !< A structure containing the - !! surface fluxes. - real, intent(in) :: dt !< The time difference in s since - !! the last call to this - !! subroutine. - - type(diag_grid_storage), intent(in) :: diag_pre_sync - !< Target grids from previous - !! timestep - type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by - !! a previous call to - !! diagnostics_init. - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< An optional barotropic + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: u !< The zonal velocity, in m s-1. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: v !< The meridional velocity, in m s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: uh !< Transport through zonal faces = u*h*dy, + !! in H m2 s-1, i.e. m3/s(Bouss) or kg/s(non-Bouss). + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: vh !< Transport through meridional faces = v*h*dx, + !! in H m2 s-1, i.e. m3/s(Bouss) or kg/s(non-Bouss). + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(accel_diag_ptrs), intent(in) :: ADp !< structure with pointers to + !! accelerations in momentum equation. + type(cont_diag_ptrs), intent(in) :: CDp !< structure with pointers to + !! terms in continuity equation. + real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure, in Pa. + !! If p_surf is not associated, it is the same + !! as setting the surface pressure to 0. + real, intent(in) :: dt !< The time difference in s since the last + !! call to this subroutine. + type(diag_grid_storage), intent(in) :: diag_pre_sync !< Target grids from previous timestep + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: eta_bt !< An optional barotropic !! variable that gives the "correct" free surface height (Boussinesq) or total water column !! mass per unit area (non-Boussinesq). This is used to dilate the layer thicknesses when !! calculating interface heights, in m or kg m-2. @@ -299,13 +294,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if (CS%id_h > 0) call post_data(CS%id_h, h, CS%diag) - if (ASSOCIATED(CS%e)) then + if (associated(CS%e)) then call find_eta(h, tv, GV%g_Earth, G, GV, CS%e, eta_bt) if (CS%id_e > 0) call post_data(CS%id_e, CS%e, CS%diag) endif - if (ASSOCIATED(CS%e_D)) then - if (ASSOCIATED(CS%e)) then + if (associated(CS%e_D)) then + if (associated(CS%e)) then do k=1,nz+1 ; do j=js,je ; do i=is,ie CS%e_D(i,j,k) = CS%e(i,j,k) + G%bathyT(i,j) enddo ; enddo ; enddo @@ -349,9 +344,9 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & endif else ! thkcello = dp/(rho*g) for non-Boussinesq do j=js,je - if(ASSOCIATED(fluxes%p_surf)) then ! Pressure loading at top of surface layer (Pa) + if (associated(p_surf)) then ! Pressure loading at top of surface layer (Pa) do i=is,ie - pressure_1d(i) = fluxes%p_surf(i,j) + pressure_1d(i) = p_surf(i,j) enddo else do i=is,ie @@ -391,7 +386,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if ((CS%id_Tpot > 0) .or. (CS%id_tob > 0)) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = gsw_pt_from_ct(tv%S(i,j,k),tv%T(i,j,k)) - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%id_Tpot > 0) call post_data(CS%id_Tpot, work_3d, CS%diag) if (CS%id_tob > 0) call post_data(CS%id_tob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) endif @@ -408,7 +403,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if ((CS%id_Sprac > 0) .or. (CS%id_sob > 0)) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = gsw_sp_from_sr(tv%S(i,j,k)) - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%id_Sprac > 0) call post_data(CS%id_Sprac, work_3d, CS%diag) if (CS%id_sob > 0) call post_data(CS%id_sob, work_3d(:,:,nz), CS%diag, mask=G%mask2dT) endif @@ -459,11 +454,11 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & call post_data_1d_k(CS%id_salt_layer_ave, salt_layer_ave, CS%diag) endif - call calculate_vertical_integrals(h, tv, fluxes, G, GV, CS) + call calculate_vertical_integrals(h, tv, p_surf, G, GV, CS) - if ((CS%id_Rml > 0) .or. (CS%id_Rcv > 0) .or. ASSOCIATED(CS%h_Rlay) .or. & - ASSOCIATED(CS%uh_Rlay) .or. ASSOCIATED(CS%vh_Rlay) .or. & - ASSOCIATED(CS%uhGM_Rlay) .or. ASSOCIATED(CS%vhGM_Rlay)) then + if ((CS%id_Rml > 0) .or. (CS%id_Rcv > 0) .or. associated(CS%h_Rlay) .or. & + associated(CS%uh_Rlay) .or. associated(CS%vh_Rlay) .or. & + associated(CS%uhGM_Rlay) .or. associated(CS%vhGM_Rlay)) then if (associated(tv%eqn_of_state)) then pressure_1d(:) = tv%P_Ref @@ -480,7 +475,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if (CS%id_Rml > 0) call post_data(CS%id_Rml, Rcv, CS%diag) if (CS%id_Rcv > 0) call post_data(CS%id_Rcv, Rcv, CS%diag) - if (ASSOCIATED(CS%h_Rlay)) then + if (associated(CS%h_Rlay)) then k_list = nz/2 !$OMP parallel do default(none) shared(is,ie,js,je,nz,nkmb,CS,Rcv,h,GV) & !$OMP private(wt,wt_p) firstprivate(k_list) @@ -501,7 +496,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if (CS%id_h_Rlay > 0) call post_data(CS%id_h_Rlay, CS%h_Rlay, CS%diag) endif - if (ASSOCIATED(CS%uh_Rlay)) then + if (associated(CS%uh_Rlay)) then k_list = nz/2 !$OMP parallel do default(none) shared(Isq,Ieq,js,je,nz,nkmb,Rcv,CS,GV,uh) & !$OMP private(wt,wt_p) firstprivate(k_list) @@ -523,7 +518,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if (CS%id_uh_Rlay > 0) call post_data(CS%id_uh_Rlay, CS%uh_Rlay, CS%diag) endif - if (ASSOCIATED(CS%vh_Rlay)) then + if (associated(CS%vh_Rlay)) then k_list = nz/2 !$OMP parallel do default(none) shared(Jsq,Jeq,is,ie,nz,nkmb,Rcv,CS,GV,vh) & !$OMP private(wt,wt_p) firstprivate(k_list) @@ -544,7 +539,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if (CS%id_vh_Rlay > 0) call post_data(CS%id_vh_Rlay, CS%vh_Rlay, CS%diag) endif - if (ASSOCIATED(CS%uhGM_Rlay) .and. ASSOCIATED(CDp%uhGM)) then + if (associated(CS%uhGM_Rlay) .and. associated(CDp%uhGM)) then k_list = nz/2 !$OMP parallel do default(none) shared(Isq,Ieq,js,je,nz,nkmb,Rcv,CDP,CS,GV) & !$OMP private(wt,wt_p) firstprivate(k_list) @@ -565,7 +560,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & if (CS%id_uh_Rlay > 0) call post_data(CS%id_uhGM_Rlay, CS%uhGM_Rlay, CS%diag) endif - if (ASSOCIATED(CS%vhGM_Rlay) .and. ASSOCIATED(CDp%vhGM)) then + if (associated(CS%vhGM_Rlay) .and. associated(CDp%vhGM)) then k_list = nz/2 !$OMP parallel do default(none) shared(is,ie,Jsq,Jeq,nz,nkmb,CS,CDp,Rcv,GV) & !$OMP private(wt,wt_p) firstprivate(k_list) @@ -696,15 +691,19 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, fluxes, & end subroutine calculate_diagnostic_fields -!> This subroutine finds location of R_in in an increasing ordered +!> This subroutine finds the location of R_in in an increasing ordered !! list, Rlist, returning as k the element such that !! Rlist(k) <= R_in < Rlist(k+1), and where wt and wt_p are the linear !! weights that should be assigned to elements k and k+1. subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) - real, intent(in) :: Rlist(:), R_in - integer, intent(inout) :: k - integer, intent(in) :: nz - real, intent(out) :: wt, wt_p + real, dimension(:), & + intent(in) :: Rlist !< The list of target densities, in kg m-3 + real, intent(in) :: R_in !< The density being inserted into Rlist, in kg m-3 + integer, intent(inout) :: k !< The value of k such that Rlist(k) <= R_in < Rlist(k+1) + !! The input value is a first guess + integer, intent(in) :: nz !< The number of layers in Rlist + real, intent(out) :: wt !< The weight of layer k for interpolation, nondim + real, intent(out) :: wt_p !< The weight of layer k+1 for interpolation, nondim ! This subroutine finds location of R_in in an increasing ordered ! list, Rlist, returning as k the element such that @@ -723,19 +722,19 @@ subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) if ((k_lower == 1) .or. (R_in >= Rlist(k_lower))) exit k_upper = k_lower inc = inc*2 - end do + enddo else do k_upper = min(k_upper+inc, nz) if ((k_upper == nz) .or. (R_in < Rlist(k_upper))) exit k_lower = k_upper inc = inc*2 - end do + enddo endif if ((k_lower == 1) .and. (R_in <= Rlist(k_lower))) then k = 1 ; wt = 1.0 ; wt_p = 0.0 - else if ((k_upper == nz) .and. (R_in >= Rlist(k_upper))) then + elseif ((k_upper == nz) .and. (R_in >= Rlist(k_upper))) then k = nz-1 ; wt = 0.0 ; wt_p = 1.0 else do @@ -746,7 +745,7 @@ subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) else k_lower = k_new endif - end do + enddo ! Uncomment this as a code check ! if ((R_in < Rlist(k_lower)) .or. (R_in >= Rlist(k_upper)) .or. (k_upper-k_lower /= 1)) & @@ -760,34 +759,21 @@ subroutine find_weights(Rlist, R_in, k, nz, wt, wt_p) end subroutine find_weights -!> Subroutine calculates vertical integrals of several tracers, along +!> This subroutine calculates vertical integrals of several tracers, along !! with the mass-weight of these tracers, the total column mass, and the !! carefully calculated column height. -subroutine calculate_vertical_integrals(h, tv, fluxes, G, GV, CS) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid - !! structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H - !! (usually m or kg m-2). - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various - !! thermodynamic variables. - type(forcing), intent(in) :: fluxes !< A structure containing the - !! surface fluxes. - type(diagnostics_CS), intent(inout) :: CS !< A control structure returned - !! by a previous call to - !! diagnostics_init. - -! Subroutine calculates vertical integrals of several tracers, along -! with the mass-weight of these tracers, the total column mass, and the -! carefully calculated column height. - -! Arguments: -! (in) h - layer thickness: metre (Bouss) or kg/ m2 (non-Bouss) -! (in) tv - structure pointing to thermodynamic variables -! (in) fluxes - a structure containing the surface fluxes. -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) CS - control structure returned by a previous call to diagnostics_init +subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + real, dimension(:,:), pointer :: p_surf !< A pointer to the surface pressure, in Pa. + !! If p_surf is not associated, it is the same + !! as setting the surface pressure to 0. + type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a + !! previous call to diagnostics_init. real, dimension(SZI_(G), SZJ_(G)) :: & z_top, & ! Height of the top of a layer or the ocean, in m. @@ -875,13 +861,12 @@ subroutine calculate_vertical_integrals(h, tv, fluxes, G, GV, CS) if (CS%id_pbo > 0) then do j=js,je ; do i=is,ie ; btm_pres(i,j) = 0.0 ; enddo ; enddo ! 'pbo' is defined as the sea water pressure at the sea floor - ! pbo = (mass * g) + pso - ! where pso is the sea water pressure at sea water surface - ! note that pso is equivalent to fluxes%p_surf + ! pbo = (mass * g) + p_surf + ! where p_surf is the sea water pressure at sea water surface. do j=js,je ; do i=is,ie btm_pres(i,j) = mass(i,j) * GV%g_Earth - if (ASSOCIATED(fluxes%p_surf)) then - btm_pres(i,j) = btm_pres(i,j) + fluxes%p_surf(i,j) + if (associated(p_surf)) then + btm_pres(i,j) = btm_pres(i,j) + p_surf(i,j) endif enddo ; enddo call post_data(CS%id_pbo, btm_pres, CS%diag) @@ -940,7 +925,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) KE_u(I,j) = 0.0 ; KE_v(i,J) = 0.0 enddo ; enddo - if (ASSOCIATED(CS%KE)) then + if (associated(CS%KE)) then do k=1,nz ; do j=js,je ; do i=is,ie CS%KE(i,j,k) = ((u(I,j,k)*u(I,j,k) + u(I-1,j,k)*u(I-1,j,k)) + & (v(i,J,k)*v(i,J,k) + v(i,J-1,k)*v(i,J-1,k)))*0.25 @@ -951,15 +936,15 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_KE > 0) call post_data(CS%id_KE, CS%KE, CS%diag) endif - if(.not.G%symmetric) then - if(ASSOCIATED(CS%dKE_dt) .OR. ASSOCIATED(CS%PE_to_KE) .OR. ASSOCIATED(CS%KE_CorAdv) .OR. & - ASSOCIATED(CS%KE_adv) .OR. ASSOCIATED(CS%KE_visc) .OR. ASSOCIATED(CS%KE_horvisc).OR. & - ASSOCIATED(CS%KE_dia) ) then + if (.not.G%symmetric) then + if (associated(CS%dKE_dt) .OR. associated(CS%PE_to_KE) .OR. associated(CS%KE_CorAdv) .OR. & + associated(CS%KE_adv) .OR. associated(CS%KE_visc) .OR. associated(CS%KE_horvisc).OR. & + associated(CS%KE_dia) ) then call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) endif endif - if (ASSOCIATED(CS%dKE_dt)) then + if (associated(CS%dKE_dt)) then do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k)*G%dxCu(I,j)*CS%du_dt(I,j,k) @@ -980,7 +965,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_dKEdt > 0) call post_data(CS%id_dKEdt, CS%dKE_dt, CS%diag) endif - if (ASSOCIATED(CS%PE_to_KE)) then + if (associated(CS%PE_to_KE)) then do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k)*G%dxCu(I,j)*ADp%PFu(I,j,k) @@ -998,7 +983,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_PE_to_KE > 0) call post_data(CS%id_PE_to_KE, CS%PE_to_KE, CS%diag) endif - if (ASSOCIATED(CS%KE_CorAdv)) then + if (associated(CS%KE_CorAdv)) then do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k)*G%dxCu(I,j)*ADp%CAu(I,j,k) @@ -1020,7 +1005,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_KE_Coradv > 0) call post_data(CS%id_KE_Coradv, CS%KE_Coradv, CS%diag) endif - if (ASSOCIATED(CS%KE_adv)) then + if (associated(CS%KE_adv)) then do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k)*G%dxCu(I,j)*ADp%gradKEu(I,j,k) @@ -1042,7 +1027,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_KE_adv > 0) call post_data(CS%id_KE_adv, CS%KE_adv, CS%diag) endif - if (ASSOCIATED(CS%KE_visc)) then + if (associated(CS%KE_visc)) then do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k)*G%dxCu(I,j)*ADp%du_dt_visc(I,j,k) @@ -1060,7 +1045,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_KE_visc > 0) call post_data(CS%id_KE_visc, CS%KE_visc, CS%diag) endif - if (ASSOCIATED(CS%KE_horvisc)) then + if (associated(CS%KE_horvisc)) then do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k)*G%dxCu(I,j)*ADp%diffu(I,j,k) @@ -1078,7 +1063,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_KE_horvisc > 0) call post_data(CS%id_KE_horvisc, CS%KE_horvisc, CS%diag) endif - if (ASSOCIATED(CS%KE_dia)) then + if (associated(CS%KE_dia)) then do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k)*G%dxCu(I,j)*ADp%du_dt_dia(I,j,k) @@ -1168,9 +1153,46 @@ subroutine calculate_derivs(dt, G, CS) end subroutine calculate_derivs +!> This routine posts diagnostics of various dynamic ocean surface quantities, +!! including velocities, speed and sea surface height, at the time the ocean +!! state is reported back to the caller +subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) + type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output + type(surface), intent(in) :: sfc_state !< structure describing the ocean surface state + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: ssh !< Time mean surface height without corrections for + !! ice displacement (m) + + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (IDs%id_ssh > 0) & + call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) + + if (IDs%id_ssu > 0) & + call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) + + if (IDs%id_ssv > 0) & + call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) + + if (IDs%id_speed > 0) then + do j=js,je ; do i=is,ie + work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & + 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) + enddo ; enddo + call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) + endif + +end subroutine post_surface_dyn_diags + + !> This routine posts diagnostics of various ocean surface and integrated !! quantities at the time the ocean state is reported back to the caller -subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & +subroutine post_surface_thermo_diags(IDs, G, GV, diag, dt_int, sfc_state, tv, & ssh, ssh_ibc) type(surface_diag_IDs), intent(in) :: IDs !< A structure with the diagnostic IDs. type(ocean_grid_type), intent(in) :: G !< ocean grid structure @@ -1201,10 +1223,6 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & call post_data(IDs%id_ssh_ga, ssh_ga, diag) endif - I_time_int = 1.0 / dt_int - if (IDs%id_ssh > 0) & - call post_data(IDs%id_ssh, ssh, diag, mask=G%mask2dT) - ! post the dynamic sea level, zos, and zossq. ! zos is ave_ssh with sea ice inverse barometer removed, ! and with zero global area mean. @@ -1235,8 +1253,11 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & call post_data(IDs%id_volo, volo, diag) endif + ! Use Adcroft's rule of reciprocals; it does the right thing here. + I_time_int = 0.0 ; if (dt_int > 0.0) I_time_int = 1.0 / dt_int + ! post time-averaged rate of frazil formation - if (ASSOCIATED(tv%frazil) .and. (IDs%id_fraz > 0)) then + if (associated(tv%frazil) .and. (IDs%id_fraz > 0)) then do j=js,je ; do i=is,ie work_2d(i,j) = tv%frazil(i,j) * I_time_int enddo ; enddo @@ -1244,7 +1265,7 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & endif ! post time-averaged salt deficit - if (ASSOCIATED(tv%salt_deficit) .and. (IDs%id_salt_deficit > 0)) then + if (associated(tv%salt_deficit) .and. (IDs%id_salt_deficit > 0)) then do j=js,je ; do i=is,ie work_2d(i,j) = tv%salt_deficit(i,j) * I_time_int enddo ; enddo @@ -1252,7 +1273,7 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & endif ! post temperature of P-E+R - if (ASSOCIATED(tv%TempxPmE) .and. (IDs%id_Heat_PmE > 0)) then + if (associated(tv%TempxPmE) .and. (IDs%id_Heat_PmE > 0)) then do j=js,je ; do i=is,ie work_2d(i,j) = tv%TempxPmE(i,j) * (tv%C_p * I_time_int) enddo ; enddo @@ -1260,7 +1281,7 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & endif ! post geothermal heating or internal heat source/sinks - if (ASSOCIATED(tv%internal_heat) .and. (IDs%id_intern_heat > 0)) then + if (associated(tv%internal_heat) .and. (IDs%id_intern_heat > 0)) then do j=js,je ; do i=is,ie work_2d(i,j) = tv%internal_heat(i,j) * (tv%C_p * I_time_int) enddo ; enddo @@ -1308,26 +1329,15 @@ subroutine post_surface_diagnostics(IDs, G, GV, diag, dt_int, sfc_state, tv, & call post_data(IDs%id_sss_sq, work_2d, diag, mask=G%mask2dT) endif - if (IDs%id_ssu > 0) & - call post_data(IDs%id_ssu, sfc_state%u, diag, mask=G%mask2dCu) - if (IDs%id_ssv > 0) & - call post_data(IDs%id_ssv, sfc_state%v, diag, mask=G%mask2dCv) - - if (IDs%id_speed > 0) then - do j=js,je ; do i=is,ie - work_2d(i,j) = sqrt(0.5*(sfc_state%u(I-1,j)**2 + sfc_state%u(I,j)**2) + & - 0.5*(sfc_state%v(i,J-1)**2 + sfc_state%v(i,J)**2)) - enddo ; enddo - call post_data(IDs%id_speed, work_2d, diag, mask=G%mask2dT) - endif - call coupler_type_send_data(sfc_state%tr_fields, get_diag_time_end(diag)) -end subroutine post_surface_diagnostics +end subroutine post_surface_thermo_diags + !> This routine posts diagnostics of the transports, including the subgridscale !! contributions. -subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, diag, dt_trans, diag_to_Z_CSp, Reg) +subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, diag, dt_trans, & + diag_to_Z_CSp, Reg) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & @@ -1372,7 +1382,7 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, d call post_data(IDs%id_umo_2d, umo2d, diag) endif if (IDs%id_umo > 0) then - ! Convert to kg/s. Modifying the array for diagnostics is allowed here since it is set to zero immediately below + ! Convert to kg/s. do k=1,nz ; do j=js,je ; do I=is-1,ie umo(I,j,k) = uhtr(I,j,k) * H_to_kg_m2_dt enddo ; enddo ; enddo @@ -1386,7 +1396,7 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, d call post_data(IDs%id_vmo_2d, vmo2d, diag) endif if (IDs%id_vmo > 0) then - ! Convert to kg/s. Modifying the array for diagnostics is allowed here since it is set to zero immediately below + ! Convert to kg/s. do k=1,nz ; do J=js-1,je ; do i=is,ie vmo(i,J,k) = vhtr(i,J,k) * H_to_kg_m2_dt enddo ; enddo ; enddo @@ -1395,7 +1405,8 @@ subroutine post_transport_diagnostics(G, GV, uhtr, vhtr, h, IDs, diag_pre_dyn, d if (IDs%id_uhtr > 0) call post_data(IDs%id_uhtr, uhtr, diag, alt_h = diag_pre_dyn%h_state) if (IDs%id_vhtr > 0) call post_data(IDs%id_vhtr, vhtr, diag, alt_h = diag_pre_dyn%h_state) - if (IDs%id_dynamics_h > 0 ) call post_data(IDs%id_dynamics_h, diag_pre_dyn%h_state, diag, alt_h = diag_pre_dyn%h_state) + if (IDs%id_dynamics_h > 0) call post_data(IDs%id_dynamics_h, diag_pre_dyn%h_state, diag, & + alt_h = diag_pre_dyn%h_state) ! Post the change in thicknesses if (IDs%id_dynamics_h_tendency > 0) then h_tend(:,:,:) = 0. @@ -1469,7 +1480,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS allocate(CS) CS%diag => diag - use_temperature = ASSOCIATED(tv%T) + use_temperature = associated(tv%T) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version) @@ -1578,21 +1589,21 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, param_file, diag, CS CS%id_du_dt = register_diag_field('ocean_model', 'dudt', diag%axesCuL, Time, & 'Zonal Acceleration', 'm s-2') - if ((CS%id_du_dt>0) .and. .not.ASSOCIATED(CS%du_dt)) then + if ((CS%id_du_dt>0) .and. .not.associated(CS%du_dt)) then call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) call register_time_deriv(MIS%u, CS%du_dt, CS) endif CS%id_dv_dt = register_diag_field('ocean_model', 'dvdt', diag%axesCvL, Time, & 'Meridional Acceleration', 'm s-2') - if ((CS%id_dv_dt>0) .and. .not.ASSOCIATED(CS%dv_dt)) then + if ((CS%id_dv_dt>0) .and. .not.associated(CS%dv_dt)) then call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) call register_time_deriv(MIS%v, CS%dv_dt, CS) endif CS%id_dh_dt = register_diag_field('ocean_model', 'dhdt', diag%axesTL, Time, & 'Thickness tendency', trim(thickness_units)//" s-1", v_extensive = .true.) - if ((CS%id_dh_dt>0) .and. .not.ASSOCIATED(CS%dh_dt)) then + if ((CS%id_dh_dt>0) .and. .not.associated(CS%dh_dt)) then call safe_alloc_ptr(CS%dh_dt,isd,ied,jsd,jed,nz) call register_time_deriv(MIS%h, CS%dh_dt, CS) endif @@ -1777,7 +1788,7 @@ subroutine register_surface_diags(Time, G, IDs, diag, tv) IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & 'Sea Surface Absolute Salinity', 'g kg-1') endif - if (ASSOCIATED(tv%frazil)) then + if (associated(tv%frazil)) then IDs%id_fraz = register_diag_field('ocean_model', 'frazil', diag%axesT1, Time, & 'Heat from frazil formation', 'W m-2', cmor_field_name='hfsifrazil', & cmor_standard_name='heat_flux_into_sea_water_due_to_frazil_ice_formation', & @@ -2036,79 +2047,82 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - if (ASSOCIATED(CS%dKE_dt) .or. ASSOCIATED(CS%PE_to_KE) .or. & - ASSOCIATED(CS%KE_CorAdv) .or. ASSOCIATED(CS%KE_adv) .or. & - ASSOCIATED(CS%KE_visc) .or. ASSOCIATED(CS%KE_horvisc) .or. & - ASSOCIATED(CS%KE_dia)) & + if (associated(CS%dKE_dt) .or. associated(CS%PE_to_KE) .or. & + associated(CS%KE_CorAdv) .or. associated(CS%KE_adv) .or. & + associated(CS%KE_visc) .or. associated(CS%KE_horvisc) .or. & + associated(CS%KE_dia)) & call safe_alloc_ptr(CS%KE,isd,ied,jsd,jed,nz) - if (ASSOCIATED(CS%dKE_dt)) then - if (.not.ASSOCIATED(CS%du_dt)) then + if (associated(CS%dKE_dt)) then + if (.not.associated(CS%du_dt)) then call safe_alloc_ptr(CS%du_dt,IsdB,IedB,jsd,jed,nz) call register_time_deriv(MIS%u, CS%du_dt, CS) endif - if (.not.ASSOCIATED(CS%dv_dt)) then + if (.not.associated(CS%dv_dt)) then call safe_alloc_ptr(CS%dv_dt,isd,ied,JsdB,JedB,nz) call register_time_deriv(MIS%v, CS%dv_dt, CS) endif - if (.not.ASSOCIATED(CS%dh_dt)) then + if (.not.associated(CS%dh_dt)) then call safe_alloc_ptr(CS%dh_dt,isd,ied,jsd,jed,nz) call register_time_deriv(MIS%h, CS%dh_dt, CS) endif endif - if (ASSOCIATED(CS%KE_adv)) then + if (associated(CS%KE_adv)) then call safe_alloc_ptr(ADp%gradKEu,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%gradKEv,isd,ied,JsdB,JedB,nz) endif - if (ASSOCIATED(CS%KE_visc)) then + if (associated(CS%KE_visc)) then call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) endif - if (ASSOCIATED(CS%KE_dia)) then + if (associated(CS%KE_dia)) then call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) endif - if (ASSOCIATED(CS%uhGM_Rlay)) call safe_alloc_ptr(CDp%uhGM,IsdB,IedB,jsd,jed,nz) - if (ASSOCIATED(CS%vhGM_Rlay)) call safe_alloc_ptr(CDp%vhGM,isd,ied,JsdB,JedB,nz) + if (associated(CS%uhGM_Rlay)) call safe_alloc_ptr(CDp%uhGM,IsdB,IedB,jsd,jed,nz) + if (associated(CS%vhGM_Rlay)) call safe_alloc_ptr(CDp%vhGM,isd,ied,JsdB,JedB,nz) end subroutine set_dependent_diagnostics +!> Deallocate memory associated with the diagnostics module subroutine MOM_diagnostics_end(CS, ADp) - type(diagnostics_CS), pointer :: CS - type(accel_diag_ptrs), intent(inout) :: ADp + type(diagnostics_CS), pointer :: CS !< Control structure returned by a + !! previous call to diagnostics_init. + type(accel_diag_ptrs), intent(inout) :: ADp !< structure with pointers to + !! accelerations in momentum equation. integer :: m - if (ASSOCIATED(CS%e)) deallocate(CS%e) - if (ASSOCIATED(CS%e_D)) deallocate(CS%e_D) - if (ASSOCIATED(CS%KE)) deallocate(CS%KE) - if (ASSOCIATED(CS%dKE_dt)) deallocate(CS%dKE_dt) - if (ASSOCIATED(CS%PE_to_KE)) deallocate(CS%PE_to_KE) - if (ASSOCIATED(CS%KE_Coradv)) deallocate(CS%KE_Coradv) - if (ASSOCIATED(CS%KE_adv)) deallocate(CS%KE_adv) - if (ASSOCIATED(CS%KE_visc)) deallocate(CS%KE_visc) - if (ASSOCIATED(CS%KE_horvisc)) deallocate(CS%KE_horvisc) - if (ASSOCIATED(CS%KE_dia)) deallocate(CS%KE_dia) - if (ASSOCIATED(CS%dv_dt)) deallocate(CS%dv_dt) - if (ASSOCIATED(CS%dh_dt)) deallocate(CS%dh_dt) - if (ASSOCIATED(CS%du_dt)) deallocate(CS%du_dt) - if (ASSOCIATED(CS%h_Rlay)) deallocate(CS%h_Rlay) - if (ASSOCIATED(CS%uh_Rlay)) deallocate(CS%uh_Rlay) - if (ASSOCIATED(CS%vh_Rlay)) deallocate(CS%vh_Rlay) - if (ASSOCIATED(CS%uhGM_Rlay)) deallocate(CS%uhGM_Rlay) - if (ASSOCIATED(CS%vhGM_Rlay)) deallocate(CS%vhGM_Rlay) - - if (ASSOCIATED(ADp%gradKEu)) deallocate(ADp%gradKEu) - if (ASSOCIATED(ADp%gradKEu)) deallocate(ADp%gradKEu) - if (ASSOCIATED(ADp%du_dt_visc)) deallocate(ADp%du_dt_visc) - if (ASSOCIATED(ADp%dv_dt_visc)) deallocate(ADp%dv_dt_visc) - if (ASSOCIATED(ADp%du_dt_dia)) deallocate(ADp%du_dt_dia) - if (ASSOCIATED(ADp%dv_dt_dia)) deallocate(ADp%dv_dt_dia) - if (ASSOCIATED(ADp%du_other)) deallocate(ADp%du_other) - if (ASSOCIATED(ADp%dv_other)) deallocate(ADp%dv_other) + if (associated(CS%e)) deallocate(CS%e) + if (associated(CS%e_D)) deallocate(CS%e_D) + if (associated(CS%KE)) deallocate(CS%KE) + if (associated(CS%dKE_dt)) deallocate(CS%dKE_dt) + if (associated(CS%PE_to_KE)) deallocate(CS%PE_to_KE) + if (associated(CS%KE_Coradv)) deallocate(CS%KE_Coradv) + if (associated(CS%KE_adv)) deallocate(CS%KE_adv) + if (associated(CS%KE_visc)) deallocate(CS%KE_visc) + if (associated(CS%KE_horvisc)) deallocate(CS%KE_horvisc) + if (associated(CS%KE_dia)) deallocate(CS%KE_dia) + if (associated(CS%dv_dt)) deallocate(CS%dv_dt) + if (associated(CS%dh_dt)) deallocate(CS%dh_dt) + if (associated(CS%du_dt)) deallocate(CS%du_dt) + if (associated(CS%h_Rlay)) deallocate(CS%h_Rlay) + if (associated(CS%uh_Rlay)) deallocate(CS%uh_Rlay) + if (associated(CS%vh_Rlay)) deallocate(CS%vh_Rlay) + if (associated(CS%uhGM_Rlay)) deallocate(CS%uhGM_Rlay) + if (associated(CS%vhGM_Rlay)) deallocate(CS%vhGM_Rlay) + + if (associated(ADp%gradKEu)) deallocate(ADp%gradKEu) + if (associated(ADp%gradKEu)) deallocate(ADp%gradKEu) + if (associated(ADp%du_dt_visc)) deallocate(ADp%du_dt_visc) + if (associated(ADp%dv_dt_visc)) deallocate(ADp%dv_dt_visc) + if (associated(ADp%du_dt_dia)) deallocate(ADp%du_dt_dia) + if (associated(ADp%dv_dt_dia)) deallocate(ADp%dv_dt_dia) + if (associated(ADp%du_other)) deallocate(ADp%du_other) + if (associated(ADp%dv_other)) deallocate(ADp%dv_other) do m=1,CS%num_time_deriv ; deallocate(CS%prev_val(m)%p) ; enddo diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 4cf55bad3b..4bd5b61255 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -64,9 +64,9 @@ end subroutine register_obsolete_diagnostics !> Fakes a register of a diagnostic to find out if an obsolete !! parameter appears in the diag_table. logical function found_in_diagtable(diag, varName, newVarName) - type(diag_ctrl), intent(in) :: diag - character(len=*), intent(in) :: varName - character(len=*), optional, intent(in) :: 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 diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index c548300bb6..7c1ee90f12 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -23,8 +23,9 @@ 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 + integer :: test_int, l_seg, nseg logical :: test_logic, test_logic2, test_logic3, split + character(len=40) :: temp_string if (.not.is_root_pe()) return @@ -68,6 +69,13 @@ subroutine find_obsolete_params(param_file) hint="Instead use OBC_SEGMENT_XXX_DATA.") call obsolete_char(param_file, "EXTEND_OBC_SEGMENTS", & hint="This option is no longer needed, nor supported.") + nseg = 0 + call read_param(param_file, "OBC_NUMBER_OF_SEGMENTS", nseg) + do l_seg = 1,nseg + write(temp_string(1:22),"('OBC_SEGMENT_',i3.3,'_TNUDGE')") l_seg + call obsolete_real(param_file, temp_string, & + hint="Instead use OBC_SEGMENT_xxx_VELOCITY_NUDGING_TIMESCALES.") + enddo test_logic3 = .true. ; call read_param(param_file,"ENABLE_THERMODYNAMICS",test_logic3) test_logic = .true. ; call read_param(param_file,"TEMPERATURE",test_logic) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index aff6a36713..8e6cd8b8f1 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -38,15 +38,15 @@ module MOM_sum_output !********+*********+*********+*********+*********+*********+*********+** use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs -use MOM_coms, only : reproducing_sum -use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_to_real, real_to_EFP +use MOM_coms, only : reproducing_sum, EFP_to_real, real_to_EFP +use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=) use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, MOM_mesg 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_interface_heights, only : find_eta -use MOM_io, only : create_file, fieldtype, flush_file, open_file, reopen_file, get_filename_appendix -use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field +use MOM_io, only : create_file, fieldtype, flush_file, open_file, reopen_file +use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, get_filename_appendix use MOM_io, only : APPEND_FILE, ASCII_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S @@ -136,7 +136,7 @@ module MOM_sum_output ! Start_time is set in MOM_initialization.F90 integer, pointer :: ntrunc ! The number of times the velocity has been ! truncated since the last call to write_energy. - real :: max_Energy ! The maximum permitted energy per unit mass; + real :: max_Energy ! The maximum permitted energy per unit mass ! If there is more energy than this, the model ! should stop, in m2 s-2. integer :: maxtrunc ! The number of truncations per energy save @@ -223,7 +223,7 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & "The maximum velocity allowed before the velocity \n"//& "components are truncated.", units="m s-1", default=3.0e8) CS%max_Energy = 10.0 * maxvel**2 - call log_param (param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) + call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) endif call get_param(param_file, mdl, "ENERGYFILE", energyfile, & @@ -232,9 +232,9 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then energyfile = trim(energyfile) //'.'//trim(filename_appendix) - end if + endif CS%energyfile = trim(slasher(directory))//trim(energyfile) call log_param(param_file, mdl, "output_path/ENERGYFILE", CS%energyfile) @@ -606,11 +606,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc else if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then time_units = " [seconds] " - else if ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then + elseif ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then time_units = " [hours] " - else if ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then + elseif ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then time_units = " [days] " - else if ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then + elseif ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then time_units = " [years] " else write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit @@ -881,7 +881,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc write(*,'(" Total ",a,": ",ES24.16,X,a)') & trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) - if(Tr_minmax_got(m)) then + if (Tr_minmax_got(m)) then write(*,'(64X,"Global Min:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) write(*,'(64X,"Global Max:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & @@ -949,24 +949,18 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc endif end subroutine write_energy -!> This subroutine accumates the net input of volume, and perhaps later salt and -!! heat, through the ocean surface for use in diagnosing conservation. +!> This subroutine accumates the net input of volume, salt and heat, through +!! the ocean surface for use in diagnosing conservation. subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) - type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible forcing fields. Unused fields are unallocated. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible + !! forcing fields. Unused fields are unallocated. type(surface), intent(in) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. real, intent(in) :: dt !< The amount of time over which to average, in s. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(Sum_output_CS), pointer :: CS !< The control structure returned by a previous call to MOM_sum_output_init. - -! This subroutine accumates the net input of volume, and perhaps later salt and -! heat, through the ocean surface for use in diagnosing conservation. -! Arguments: fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields are unallocated. -! (in) dt - The amount of time over which to average. -! (in) G - The ocean's grid structure. -! (in) CS - The control structure returned by a previous call to -! MOM_sum_output_init. + type(Sum_output_CS), pointer :: CS !< The control structure returned by a previous call + !! to MOM_sum_output_init. + real, dimension(SZI_(G),SZJ_(G)) :: & FW_in, & ! The net fresh water input, integrated over a timestep in kg. salt_in, & ! The total salt added by surface fluxes, integrated @@ -993,8 +987,8 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) C_p = fluxes%C_p FW_in(:,:) = 0.0 ; FW_input = 0.0 - if (ASSOCIATED(fluxes%evap)) then - if (ASSOCIATED(fluxes%lprec) .and. ASSOCIATED(fluxes%fprec)) then + if (associated(fluxes%evap)) then + if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie FW_in(i,j) = dt*G%areaT(i,j)*(fluxes%evap(i,j) + & (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + fluxes%lrunoff(i,j)) + & @@ -1009,14 +1003,14 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) salt_in(:,:) = 0.0 ; heat_in(:,:) = 0.0 if (CS%use_temperature) then - if (ASSOCIATED(fluxes%sw)) then ; do j=js,je ; do i=is,ie + if (associated(fluxes%sw)) then ; do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + dt*G%areaT(i,j) * (fluxes%sw(i,j) + & (fluxes%lw(i,j) + (fluxes%latent(i,j) + fluxes%sens(i,j)))) enddo ; enddo ; endif ! smg: new code ! include heat content from water transport across ocean surface -! if (ASSOCIATED(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie +! if (associated(fluxes%heat_content_lprec)) then ; do j=js,je ; do i=is,ie ! heat_in(i,j) = heat_in(i,j) + dt*G%areaT(i,j) * & ! (fluxes%heat_content_lprec(i,j) + (fluxes%heat_content_fprec(i,j) & ! + (fluxes%heat_content_lrunoff(i,j) + (fluxes%heat_content_frunoff(i,j) & @@ -1025,11 +1019,11 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) ! enddo ; enddo ; endif ! smg: old code - if (ASSOCIATED(sfc_state%TempxPmE)) then + if (associated(sfc_state%TempxPmE)) then do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + (C_p * G%areaT(i,j)) * sfc_state%TempxPmE(i,j) enddo ; enddo - elseif (ASSOCIATED(fluxes%evap)) then + elseif (associated(fluxes%evap)) then do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + (C_p * sfc_state%SST(i,j)) * FW_in(i,j) enddo ; enddo @@ -1037,30 +1031,30 @@ subroutine accumulate_net_input(fluxes, sfc_state, dt, G, CS) ! The following heat sources may or may not be used. - if (ASSOCIATED(sfc_state%internal_heat)) then + if (associated(sfc_state%internal_heat)) then do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + (C_p * G%areaT(i,j)) * & sfc_state%internal_heat(i,j) enddo ; enddo endif - if (ASSOCIATED(sfc_state%frazil)) then ; do j=js,je ; do i=is,ie + if (associated(sfc_state%frazil)) then ; do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + G%areaT(i,j) * sfc_state%frazil(i,j) enddo ; enddo ; endif - if (ASSOCIATED(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie + if (associated(fluxes%heat_added)) then ; do j=js,je ; do i=is,ie heat_in(i,j) = heat_in(i,j) + dt*G%areaT(i,j)*fluxes%heat_added(i,j) enddo ; enddo ; endif -! if (ASSOCIATED(sfc_state%sw_lost)) then ; do j=js,je ; do i=is,ie +! if (associated(sfc_state%sw_lost)) then ; do j=js,je ; do i=is,ie ! heat_in(i,j) = heat_in(i,j) - G%areaT(i,j) * sfc_state%sw_lost(i,j) ! enddo ; enddo ; endif - if (ASSOCIATED(fluxes%salt_flux)) then ; do j=js,je ; do i=is,ie + if (associated(fluxes%salt_flux)) then ; do j=js,je ; do i=is,ie ! convert salt_flux from kg (salt)/(m^2 s) to ppt * (m/s). salt_in(i,j) = dt*G%areaT(i,j)*(1000.0*fluxes%salt_flux(i,j)) enddo ; enddo ; endif endif - if ((CS%use_temperature) .or. ASSOCIATED(fluxes%lprec) .or. & - ASSOCIATED(fluxes%evap)) then + if ((CS%use_temperature) .or. associated(fluxes%lprec) .or. & + associated(fluxes%evap)) then FW_input = reproducing_sum(FW_in, EFP_sum=FW_in_EFP) heat_input = reproducing_sum(heat_in, EFP_sum=heat_in_EFP) salt_input = reproducing_sum(salt_in, EFP_sum=salt_in_EFP) @@ -1082,7 +1076,8 @@ end subroutine accumulate_net_input !! or it might be created anew. (For now only new creation occurs. subroutine depth_list_setup(G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(Sum_output_CS), pointer :: CS + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. ! This subroutine sets up an ordered list of depths, along with the ! cross sectional areas at each depth and the volume of fluid deeper ! than each depth. This might be read from a previously created file @@ -1238,10 +1233,11 @@ end subroutine create_depth_list !> This subroutine writes out the depth list to the specified file. subroutine write_depth_list(G, CS, filename, list_size) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(Sum_output_CS), pointer :: CS - character(len=*), intent(in) :: filename - integer, intent(in) :: list_size + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + character(len=*), intent(in) :: filename !< The path to the depth list file to write. + integer, intent(in) :: list_size !< The size of the depth list. ! This subroutine writes out the depth list to the specified file. @@ -1320,9 +1316,10 @@ end subroutine write_depth_list !> This subroutine reads in the depth list to the specified file !! and allocates and sets up CS%DL and CS%list_size . subroutine read_depth_list(G, CS, filename) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(Sum_output_CS), pointer :: CS - character(len=*), intent(in) :: filename + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(Sum_output_CS), pointer :: CS !< The control structure returned by a + !! previous call to MOM_sum_output_init. + character(len=*), intent(in) :: filename !< The path to the depth list file to read. ! This subroutine reads in the depth list to the specified file ! and allocates and sets up CS%DL and CS%list_size . @@ -1334,7 +1331,7 @@ subroutine read_depth_list(G, CS, filename) mdl = "MOM_sum_output read_depth_list:" - status = NF90_OPEN(filename, NF90_NOWRITE, ncid); + status = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(FATAL,mdl//" Difficulties opening "//trim(filename)// & " - "//trim(NF90_STRERROR(status))) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index fbd0ce2daa..9244b33738 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -25,9 +25,9 @@ module MOM_wave_speed !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as - !! monotonic for the purposes of calculating the equivalent barotropic wave speed. - !! This parameter controls the default behavior of wave_speed() which - !! can be overridden by optional arguments. + !! monotonic for the purposes of calculating the equivalent barotropic + !! wave speed. This parameter controls the default behavior of + !! wave_speed() which can be overridden by optional arguments. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of !! calculating the equivalent barotropic wave speed. (m) !! This parameter controls the default behavior of wave_speed() which @@ -42,23 +42,25 @@ module MOM_wave_speed !> Calculates the wave speed of the first baroclinic mode. subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & mono_N2_column_fraction, mono_N2_depth, modal_structure) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness in units of H (m or kg/m2) - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed (m/s) - type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational domain. - logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent - !! barotropic mode instead of the first baroclinic mode. - real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction - !! of water column over which N2 is limited as monotonic - !! for the purposes of calculating vertical modal structure. - real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as - !! monotonic for the purposes of calculating vertical modal structure. + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness in units of H (m or kg/m2) + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed (m/s) + type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed + logical, optional, intent(in) :: full_halos !< If true, do the calculation + !! over the entire computational domain. + logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent + !! barotropic mode instead of the first baroclinic mode. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction + !! of water column over which N2 is limited as monotonic + !! for the purposes of calculating vertical modal structure. + real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as + !! monotonic for the purposes of calculating vertical + !! modal structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - optional, intent(out) :: modal_structure !< Normalized model structure (non-dim) + optional, intent(out) :: modal_structure !< Normalized model structure (non-dim) ! Local variables real, dimension(SZK_(G)+1) :: & @@ -118,7 +120,7 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & if (calc_modal_structure) then do k=1,nz; do j=js,je; do i=is,ie modal_structure(i,j,k) = 0.0 - enddo; enddo; enddo + enddo ; enddo ; enddo endif S => tv%S ; T => tv%T @@ -354,7 +356,8 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & do itt=1,max_itt lam_it(itt) = lam if (l_use_ebt_mode) then - ! This initialization of det,ddet imply Neumann boundary conditions so that first 3 rows of the matrix are + ! This initialization of det,ddet imply Neumann boundary conditions so that first 3 rows + ! of the matrix are ! / b(1)-lam igl(1) 0 0 0 ... \ ! | igu(2) b(2)-lam igl(2) 0 0 ... | ! | 0 igu(3) b(3)-lam igl(3) 0 ... | @@ -373,7 +376,8 @@ subroutine wave_speed(h, tv, G, GV, cg1, CS, full_halos, use_ebt_mode, & ! | ... 0 igu(kc-1) b(kc-1)-lam igl(kc-1) | ! \ ... 0 0 igu(kc) b(kc)-lam / else - ! This initialization of det,ddet imply Dirichlet boundary conditions so that first 3 rows of the matrix are + ! This initialization of det,ddet imply Dirichlet boundary conditions so that first 3 rows + ! of the matrix are ! / b(2)-lam igl(2) 0 0 0 ... | ! | igu(3) b(3)-lam igl(3) 0 0 ... | ! | 0 igu43) b(4)-lam igl(4) 0 ... | @@ -845,8 +849,8 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) enddo ! print resutls (for debugging only) - !if(ig .eq. 83 .and. jg .eq. 2) then - ! if(nmodes>1)then + !if (ig == 83 .and. jg == 2) then + ! if (nmodes>1)then ! print *, "Results after finding first mode:" ! print *, "first guess at lam_1=", 1./speed2_tot ! print *, "final guess at lam_1=", lam_1 @@ -874,7 +878,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! set number of intervals within search range numint = nint((lamMax - lamMin)/lamInc) - !if(ig .eq. 144 .and. jg .eq. 5) then + !if (ig == 144 .and. jg == 5) then ! print *, 'Looking for other eigenvalues at', ig, jg ! print *, 'Wave_speed: lamMin=', lamMin ! print *, 'Wave_speed: cnMax=', 1/sqrt(lamMin) @@ -895,7 +899,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) xl = xr - lamInc call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & nrows,xr,det_r,ddet_r) - !if(ig .eq. 83 .and. jg .eq. 2) then + !if (ig == 83 .and. jg == 2) then ! print *, "Move interval" ! print *, "iint=",iint ! print *, "@ xr=",xr @@ -907,7 +911,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) nrootsfound = nrootsfound + 1 xbl(nrootsfound) = xl xbr(nrootsfound) = xr - !if(ig .eq. 144 .and. jg .eq. 5) then + !if (ig == 144 .and. jg == 5) then ! print *, "Root located without subdivision!" ! print *, "between xbl=",xl,"and xbr=",xr !endif @@ -935,7 +939,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) nrootsfound = nrootsfound + 1 xbl(nrootsfound) = xl_sub xbr(nrootsfound) = xr - !if(ig .eq. 144 .and. jg .eq. 5) then + !if (ig == 144 .and. jg == 5) then ! print *, "Root located after subdiving",sub_it," times!" ! print *, "between xbl=",xl_sub,"and xbr=",xr !endif @@ -950,7 +954,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) call MOM_error(WARNING, "wave_speed: root not found "// & " after sub_it_max subdivisions of original"// & " interval.") - !if(ig .eq. 144 .and. jg .eq. 5) then + !if (ig == 144 .and. jg == 5) then !print *, "xbl=",xbl !print *, "xbr=",xbr !print *, "Wave_speed: kc=",kc @@ -975,7 +979,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! oops, lamMax not large enough - could add code to increase (BDM) ! set unfound modes to zero for now (BDM) cn(i,j,nrootsfound+2:nmodes) = 0.0 - !if(ig .eq. 83 .and. jg .eq. 2) then + !if (ig == 83 .and. jg == 2) then ! call MOM_error(WARNING, "wave_speed: not all modes found "// & ! " within search range: increase numint.") ! print *, "Increase lamMax at ig=",ig," jg=",jg @@ -1026,7 +1030,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! ----- Spot check - comment out later (BDM) ---------- !ig = G%idg_offset + i !jg = G%jdg_offset + j - !if (ig .eq. 83 .and. jg .eq. 2) then + !if (ig == 83 .and. jg == 2) then !! print *, "nmodes=",nmodes ! print *, "lam_1=",lam_1 ! print *, "lamMin=",lamMin @@ -1061,9 +1065,9 @@ subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) real :: I_rescale ! inverse of rescale integer :: n ! row (layer interface) index - if (size(b) .ne. nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") - if (size(a) .ne. nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") - if (size(c) .ne. nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") + if (size(b) /= nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") + if (size(a) /= nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") + if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") I_rescale = 1.0/rescale @@ -1088,10 +1092,12 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. - real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over which N2 is limited - !! as monotonic for the purposes of calculating vertical modal structure. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over + !! which N2 is limited as monotonic for the purposes of + !! calculating the vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited - !! as monotonic for the purposes of calculating vertical modal structure. + !! as monotonic for the purposes of calculating the + !! vertical modal structure. ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_wave_speed" ! This module's name. @@ -1116,10 +1122,12 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ type(wave_speed_CS), pointer :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. - real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over which N2 is limited - !! as monotonic for the purposes of calculating vertical modal structure. + real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over + !! which N2 is limited as monotonic for the purposes of + !! calculating the vertical modal structure. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited - !! as monotonic for the purposes of calculating vertical modal structure. + !! as monotonic for the purposes of calculating the + !! vertical modal structure. if (.not.associated(CS)) call MOM_error(FATAL, & "wave_speed_set_param called with an associated control structure.") diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 1db88cb804..b0a889b722 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -272,10 +272,10 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) ! 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 .eq. CS%int_tide_source_x .and. jg .eq. CS%int_tide_source_y) then + !if (ig == CS%int_tide_source_x .and. jg == CS%int_tide_source_y) then !----------------------------------- if (G%mask2dT(i,j) > 0.5) then @@ -423,10 +423,10 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) a_diag(row) = gprime(K)*(-Igu(K)) b_diag(row) = gprime(K)*(Igu(K)+Igl(K)) - lam_z(row) c_diag(row) = gprime(K)*(-Igl(K)) - if(isnan(lam_z(row)))then ; print *, "Wave_structure: lam_z(row) is NAN" ; endif - if(isnan(a_diag(row)))then ; print *, "Wave_structure: a(k) is NAN" ; endif - if(isnan(b_diag(row)))then ; print *, "Wave_structure: b(k) is NAN" ; endif - if(isnan(c_diag(row)))then ; print *, "Wave_structure: c(k) is NAN" ; endif + if (isnan(lam_z(row)))then ; print *, "Wave_structure: lam_z(row) is NAN" ; endif + if (isnan(a_diag(row)))then ; print *, "Wave_structure: a(k) is NAN" ; endif + if (isnan(b_diag(row)))then ; print *, "Wave_structure: b(k) is NAN" ; endif + if (isnan(c_diag(row)))then ; print *, "Wave_structure: c(k) is NAN" ; endif enddo ! Populate top row of tridiagonal matrix K=2 ; row = K-1 @@ -457,9 +457,9 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) ! Check to see if solver worked ig_stop = 0 ; jg_stop = 0 - if(isnan(sum(w_strct(1:kc+1))))then + if (isnan(sum(w_strct(1:kc+1))))then print *, "Wave_structure: w_strct has a NAN at ig=", ig, ", jg=", jg - if(iG%iec .or. jG%jec)then + if (iG%iec .or. jG%jec)then print *, "This is occuring at a halo point." endif ig_stop = ig ; jg_stop = jg @@ -534,7 +534,7 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) CS%num_intfaces(i,j) = nzm !----for debugging; delete later---- - !if(ig .eq. ig_stop .and. jg .eq. jg_stop) then + !if (ig == ig_stop .and. jg == jg_stop) then !print *, 'cn(ig,jg)=', cn(i,j) !print *, "e_guess=", e_guess(1:kc-1) !print *, "|e_guess|=", sqrt(sum(e_guess(1:kc-1)**2)) @@ -598,7 +598,7 @@ end subroutine wave_structure !> This subroutine solves a tri-diagonal system Ax=y using either the standard !! Thomas algorithim (TDMA_T) or its more stable variant that invokes the !! "Hallberg substitution" (TDMA_H). -subroutine tridiag_solver(a,b,c,h,y,method,x) +subroutine tridiag_solver(a, b, c, h, y, method, x) real, dimension(:), intent(in) :: a !< lower diagonal with first entry equal to zero. real, dimension(:), intent(in) :: b !< middle diagonal. real, dimension(:), intent(in) :: c !< upper diagonal with last entry equal to zero. @@ -610,7 +610,7 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) !! where a(k)=[-alpha(k-1/2)], b(k)=[alpha(k-1/2)+alpha(k+1/2) + h(k)], !! and c(k)=[-alpha(k+1/2)]. Only used with TDMA_H method. real, dimension(:), intent(in) :: y !< vector of known values on right hand side. - character(len=*), intent(in) :: method + character(len=*), intent(in) :: method !< A string describing the algorithm to use real, dimension(:), intent(out) :: x !< vector of unknown values to solve for. ! This subroutine solves a tri-diagonal system Ax=y using either the standard @@ -673,14 +673,14 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) ! Check results - delete later !do j=1,nrow ; do i=1,nrow - ! if(i==j)then ; A_check(i,j) = b(i) - ! elseif(i==j+1)then ; A_check(i,j) = a(i) - ! elseif(i==j-1)then ; A_check(i,j) = c(i) + ! if (i==j)then ; A_check(i,j) = b(i) + ! elseif (i==j+1)then ; A_check(i,j) = a(i) + ! elseif (i==j-1)then ; A_check(i,j) = c(i) ! endif !enddo ; enddo !print *, 'A(2,1),A(2,2),A(1,2)=', A_check(2,1), A_check(2,2), A_check(1,2) !y_check = matmul(A_check,x) - !if(all(y_check .ne. y))then + !if (all(y_check /= y))then ! print *, "tridiag_solver: Uh oh, something's not right!" ! print *, "y=", y ! print *, "y_check=", y_check @@ -713,12 +713,12 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) ! Forward sweep do k=2,nrow-1 beta = 1/(h(k)+alpha(k-1)*Q_prime+alpha(k)) - if(isnan(beta))then ; print *, "Tridiag_solver: beta is NAN" ; endif + if (isnan(beta))then ; print *, "Tridiag_solver: beta is NAN" ; endif q(k) = beta*alpha(k) y_prime(k) = beta*(y(k)+alpha(k-1)*y_prime(k-1)) Q_prime = beta*(h(k)+alpha(k-1)*Q_prime) enddo - if((h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) == 0.0)then + if ((h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) == 0.0)then call MOM_error(WARNING, "Tridiag_solver: this system is not stable; overriding beta(nrow).") beta = 1/(1e-15) ! place holder for unstable systems - delete later else diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 65d80d0009..2df645c338 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -3,29 +3,30 @@ module MOM_EOS ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_EOS_linear, only : calculate_density_linear +use MOM_EOS_linear, only : calculate_density_linear, calculate_spec_vol_linear use MOM_EOS_linear, only : calculate_density_derivs_linear use MOM_EOS_linear, only : calculate_specvol_derivs_linear, int_density_dz_linear use MOM_EOS_linear, only : calculate_density_second_derivs_linear use MOM_EOS_linear, only : calculate_compress_linear, int_spec_vol_dp_linear -use MOM_EOS_Wright, only : calculate_density_wright, calculate_density_wright +use MOM_EOS_Wright, only : calculate_density_wright, calculate_spec_vol_wright use MOM_EOS_Wright, only : calculate_density_derivs_wright use MOM_EOS_Wright, only : calculate_specvol_derivs_wright, int_density_dz_wright use MOM_EOS_Wright, only : calculate_compress_wright, int_spec_vol_dp_wright use MOM_EOS_Wright, only : calculate_density_second_derivs_wright -use MOM_EOS_UNESCO, only : calculate_density_unesco +use MOM_EOS_UNESCO, only : calculate_density_unesco, calculate_spec_vol_unesco use MOM_EOS_UNESCO, only : calculate_density_derivs_unesco, calculate_density_unesco use MOM_EOS_UNESCO, only : calculate_compress_unesco use MOM_EOS_NEMO, only : calculate_density_nemo use MOM_EOS_NEMO, only : calculate_density_derivs_nemo, calculate_density_nemo use MOM_EOS_NEMO, only : calculate_compress_nemo -use MOM_EOS_TEOS10, only : calculate_density_teos10 +use MOM_EOS_TEOS10, only : calculate_density_teos10, calculate_spec_vol_teos10 use MOM_EOS_TEOS10, only : calculate_density_derivs_teos10 use MOM_EOS_TEOS10, only : calculate_specvol_derivs_teos10 use MOM_EOS_TEOS10, only : calculate_density_second_derivs_teos10 use MOM_EOS_TEOS10, only : calculate_compress_teos10 use MOM_EOS_TEOS10, only : gsw_sp_from_sr, gsw_pt_from_ct -use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero, calculate_TFreeze_teos10 +use MOM_TFreeze, only : calculate_TFreeze_linear, calculate_TFreeze_Millero +use MOM_TFreeze, only : calculate_TFreeze_teos10 use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_string_functions, only : uppercase @@ -36,12 +37,14 @@ module MOM_EOS #include public calculate_compress, calculate_density, query_compressible -public calculate_density_derivs, calculate_specific_vol_derivs, calculate_density_second_derivs +public calculate_density_derivs, calculate_specific_vol_derivs +public calculate_density_second_derivs public EOS_init, EOS_manual_init, EOS_end, EOS_allocate -public EOS_use_linear +public EOS_use_linear, calculate_spec_vol public int_density_dz, int_specific_vol_dp public int_density_dz_generic_plm, int_density_dz_generic_ppm -public int_density_dz_generic_plm_analytic +public int_spec_vol_dp_generic_plm !, int_spec_vol_dz_generic_ppm +public int_density_dz_generic, int_spec_vol_dp_generic public find_depth_of_pressure_in_cell public calculate_TFreeze public convert_temp_salt_for_TEOS10 @@ -53,6 +56,11 @@ module MOM_EOS module procedure calculate_density_scalar, calculate_density_array end interface calculate_density +!> Calculates specific volume of sea water from T, S and P +interface calculate_spec_vol + module procedure calculate_spec_vol_scalar, calculate_spec_vol_array +end interface calculate_spec_vol + interface calculate_density_derivs module procedure calculate_density_derivs_scalar, calculate_density_derivs_array end interface calculate_density_derivs @@ -84,6 +92,8 @@ module MOM_EOS real :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 in deg C. real :: dTFr_dS !< The derivative of freezing point with salinity, in deg C PSU-1. real :: dTFr_dp !< The derivative of freezing point with pressure, in deg C Pa-1. + + logical :: test_EOS = .true. end type EOS_type ! The named integers that might be stored in eqn_of_state_type%form_of_EOS. @@ -111,12 +121,14 @@ module MOM_EOS contains !> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. -subroutine calculate_density_scalar(T, S, pressure, rho, EOS) +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref) real, intent(in) :: T !< Potential temperature referenced to the surface (degC) real, intent(in) :: S !< Salinity (PSU) real, intent(in) :: pressure !< Pressure (Pa) real, intent(out) :: rho !< Density (in-situ if pressure is local) (kg m-3) type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_scalar called with an unassociated EOS_type EOS.") @@ -124,15 +136,15 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS) select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_density_linear(T, S, pressure, rho, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho) + call calculate_density_unesco(T, S, pressure, rho, rho_ref) case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho) + call calculate_density_wright(T, S, pressure, rho, rho_ref) case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho) + call calculate_density_teos10(T, S, pressure, rho, rho_ref) case (EOS_NEMO) - call calculate_density_nemo(T, S, pressure, rho) + call calculate_density_nemo(T, S, pressure, rho, rho_ref) case default call MOM_error(FATAL, & "calculate_density_scalar: EOS is not valid.") @@ -141,7 +153,8 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS) end subroutine calculate_density_scalar !> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. -subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS) +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. +subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) real, dimension(:), intent(in) :: S !< Salinity (PSU) real, dimension(:), intent(in) :: pressure !< Pressure (Pa) @@ -149,6 +162,7 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS) integer, intent(in) :: start !< Start index for computation integer, intent(in) :: npts !< Number of point to compute type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_array called with an unassociated EOS_type EOS.") @@ -156,15 +170,15 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS) select case (EOS%form_of_EOS) case (EOS_LINEAR) call calculate_density_linear(T, S, pressure, rho, start, npts, & - EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS) + EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, rho_ref) case (EOS_UNESCO) - call calculate_density_unesco(T, S, pressure, rho, start, npts) + call calculate_density_unesco(T, S, pressure, rho, start, npts, rho_ref) case (EOS_WRIGHT) - call calculate_density_wright(T, S, pressure, rho, start, npts) + call calculate_density_wright(T, S, pressure, rho, start, npts, rho_ref) case (EOS_TEOS10) - call calculate_density_teos10(T, S, pressure, rho, start, npts) + call calculate_density_teos10(T, S, pressure, rho, start, npts, rho_ref) case (EOS_NEMO) - call calculate_density_nemo (T, S, pressure, rho, start, npts) + call calculate_density_nemo (T, S, pressure, rho, start, npts, rho_ref) case default call MOM_error(FATAL, & "calculate_density_array: EOS%form_of_EOS is not valid.") @@ -172,11 +186,96 @@ subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS) end subroutine calculate_density_array +!> Calls the appropriate subroutine to calculate specific volume of sea water +!! for scalar inputs. +subroutine calculate_spec_vol_scalar(T, S, pressure, specvol, EOS, spv_ref) + real, intent(in) :: T !< Potential temperature referenced to the surface (degC) + real, intent(in) :: S !< Salinity (PSU) + real, intent(in) :: pressure !< Pressure (Pa) + real, intent(out) :: specvol !< specific volume (in-situ if pressure is local) (m3 kg-1) + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + + real :: rho + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_spec_vol_scalar called with an unassociated EOS_type EOS.") + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_spec_vol_linear(T, S, pressure, specvol, & + EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS, spv_ref) + case (EOS_UNESCO) + call calculate_spec_vol_unesco(T, S, pressure, specvol, spv_ref) + case (EOS_WRIGHT) + call calculate_spec_vol_wright(T, S, pressure, specvol, spv_ref) + case (EOS_TEOS10) + call calculate_spec_vol_teos10(T, S, pressure, specvol, spv_ref) + case (EOS_NEMO) + call calculate_density_nemo(T, S, pressure, rho) + if (present(spv_ref)) then + specvol = 1.0 / rho - spv_ref + else + specvol = 1.0 / rho + endif + case default + call MOM_error(FATAL, & + "calculate_spec_vol_scalar: EOS is not valid.") + end select + +end subroutine calculate_spec_vol_scalar + + +!> Calls the appropriate subroutine to calculate the specific volume of sea water +!! for 1-D array inputs. +subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, spv_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface + !! in C. + real, dimension(:), intent(in) :: S !< salinity in PSU. + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: specvol !< in situ specific volume in kg m-3. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + type(EOS_type), pointer :: EOS !< Equation of state structure + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + + real, dimension(size(specvol)) :: rho + + + if (.not.associated(EOS)) call MOM_error(FATAL, & + "calculate_spec_vol_array called with an unassociated EOS_type EOS.") + + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + call calculate_spec_vol_linear(T, S, pressure, specvol, start, npts, & + EOS%rho_T0_S0, EOS%drho_dT, EOS%drho_dS, spv_ref) + case (EOS_UNESCO) + call calculate_spec_vol_unesco(T, S, pressure, specvol, start, npts, spv_ref) + case (EOS_WRIGHT) + call calculate_spec_vol_wright(T, S, pressure, specvol, start, npts, spv_ref) + case (EOS_TEOS10) + call calculate_spec_vol_teos10(T, S, pressure, specvol, start, npts, spv_ref) + case (EOS_NEMO) + call calculate_density_nemo (T, S, pressure, rho, start, npts) + if (present(spv_ref)) then + specvol(:) = 1.0 / rho(:) - spv_ref + else + specvol(:) = 1.0 / rho(:) + endif + case default + call MOM_error(FATAL, & + "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") + end select + +end subroutine calculate_spec_vol_array + + !> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS) real, intent(in) :: S !< Salinity (PSU) real, intent(in) :: pressure !< Pressure (Pa) - real, intent(out) :: T_fr !< Freezing point potential temperature referenced to the surface (degC) + real, intent(out) :: T_fr !< Freezing point potential temperature referenced + !! to the surface (degC) type(EOS_type), pointer :: EOS !< Equation of state structure if (.not.associated(EOS)) call MOM_error(FATAL, & @@ -201,7 +300,8 @@ end subroutine calculate_TFreeze_scalar subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS) real, dimension(:), intent(in) :: S !< Salinity (PSU) real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: T_fr !< Freezing point potential temperature referenced to the surface (degC) + real, dimension(:), intent(out) :: T_fr !< Freezing point potential temperature referenced + !! to the surface (degC) integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure @@ -229,8 +329,10 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) real, dimension(:), intent(in) :: S !< Salinity (PSU) real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: drho_dT !< The partial derivative of density with potential tempetature, in kg m-3 K-1. - real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, in kg m-3 psu-1. + real, dimension(:), intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature, in kg m-3 K-1. + real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in kg m-3 psu-1. integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure @@ -240,8 +342,8 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - start, npts) + call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, EOS%Rho_T0_S0, & + EOS%dRho_dT, EOS%dRho_dS, start, npts) case (EOS_UNESCO) call calculate_density_derivs_unesco(T, S, pressure, drho_dT, drho_dS, start, npts) case (EOS_WRIGHT) @@ -257,13 +359,16 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star end subroutine calculate_density_derivs_array -!> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar to a one-element array +!> Calls the appropriate subroutines to calculate density derivatives by promoting a scalar +!! to a one-element array subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS) real, intent(in) :: T !< Potential temperature referenced to the surface (degC) real, intent(in) :: S !< Salinity (PSU) real, intent(in) :: pressure !< Pressure (Pa) - real, intent(out) :: drho_dT !< The partial derivative of density with potential tempetature, in kg m-3 K-1. - real, intent(out) :: drho_dS !< The partial derivative of density with salinity, in kg m-3 psu-1. + real, intent(out) :: drho_dT !< The partial derivative of density with potential + !! temperature, in kg m-3 K-1. + real, intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! in kg m-3 psu-1. type(EOS_type), pointer :: EOS !< Equation of state structure if (.not.associated(EOS)) call MOM_error(FATAL, & "calculate_density_derivs called with an unassociated EOS_type EOS.") @@ -284,8 +389,8 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS end subroutine calculate_density_derivs_scalar !> Calls the appropriate subroutine to calculate density second derivatives for 1-D array inputs. -subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & - start, npts, EOS) +subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & + drho_dS_dP, drho_dT_dP, start, npts, EOS) real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) real, dimension(:), intent(in) :: S !< Salinity (PSU) real, dimension(:), intent(in) :: pressure !< Pressure (Pa) @@ -303,14 +408,14 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP, start, npts) + call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP, start, npts) + call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP, start, npts) + call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) case default call MOM_error(FATAL, & "calculate_density_derivs: EOS%form_of_EOS is not valid.") @@ -319,8 +424,8 @@ subroutine calculate_density_second_derivs_array(T, S, pressure, drho_dS_dS, drh end subroutine calculate_density_second_derivs_array !> Calls the appropriate subroutine to calculate density second derivatives for scalar nputs. -subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & - EOS) +subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & + drho_dS_dP, drho_dT_dP, EOS) real, intent(in) :: T !< Potential temperature referenced to the surface (degC) real, intent(in) :: S !< Salinity (PSU) real, intent(in) :: pressure !< Pressure (Pa) @@ -336,14 +441,14 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr select case (EOS%form_of_EOS) case (EOS_LINEAR) - call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP) + call calculate_density_second_derivs_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_WRIGHT) - call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP) + call calculate_density_second_derivs_wright(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case (EOS_TEOS10) - call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP) + call calculate_density_second_derivs_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) case default call MOM_error(FATAL, & "calculate_density_derivs: EOS%form_of_EOS is not valid.") @@ -356,8 +461,10 @@ subroutine calculate_specific_vol_derivs(T, S, pressure, dSV_dT, dSV_dS, start, real, dimension(:), intent(in) :: T !< Potential temperature referenced to the surface (degC) real, dimension(:), intent(in) :: S !< Salinity (PSU) real, dimension(:), intent(in) :: pressure !< Pressure (Pa) - real, dimension(:), intent(out) :: dSV_dT !< The partial derivative of specific volume with potential temperature, in m3 kg-1 K-1. - real, dimension(:), intent(out) :: dSV_dS !< The partial derivative of specific volume with salinity, in m3 kg-1 / (g/kg). + real, dimension(:), intent(out) :: dSV_dT !< The partial derivative of specific volume with potential + !! temperature, in m3 kg-1 K-1. + real, dimension(:), intent(out) :: dSV_dS !< The partial derivative of specific volume with salinity, + !! in m3 kg-1 / (g/kg). integer, intent(in) :: start !< Starting index within the array integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), pointer :: EOS !< Equation of state structure @@ -438,7 +545,8 @@ end subroutine calculate_compress !! use of Bode's rule to do the horizontal integrals, and from a truncation in the !! series for log(1-eps/1+eps) that assumes that |eps| < . subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size) + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) !> The horizontal index structure type(hor_index_type), intent(in) :: HI !> Potential temperature referenced to the surface (degC) @@ -468,36 +576,44 @@ subroutine int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), optional, intent(out) :: inty_dza !> The width of halo points on which to calculate dza. integer, optional, intent(in) :: halo_size + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry in Pa + real, optional, intent(in) :: dP_tiny !< A miniscule pressure change with + !! the same units as p_t (Pa?) + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. if (.not.associated(EOS)) call MOM_error(FATAL, & "int_specific_vol_dp called with an unassociated EOS_type EOS.") if (EOS%EOS_quadrature) then call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size) + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) call int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, EOS%Rho_T0_S0, & EOS%dRho_dT, EOS%dRho_dS, dza, intp_dza, & - intx_dza, inty_dza, halo_size) + intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) case (EOS_WRIGHT) call int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size) + intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) case default call int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size) + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_tiny, useMassWghtInterp) end select ; endif end subroutine int_specific_vol_dp !> This subroutine calculates analytical and nearly-analytical integrals of !! pressure anomalies across layers, which are required for calculating the -!! finite-volume form pressure accelerations in a Boussinesq model. The one -!! potentially dodgy assumtion here is that rho_0 is used both in the denominator -!! of the accelerations, and in the pressure used to calculated density (the latter -!! being -z*rho_0*G_e). These two uses could be separated if need be. +!! finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, & - dpa, intz_dpa, intx_dpa, inty_dpa) + dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) !> Ocean horizontal index structures for the input arrays type(hor_index_type), intent(in) :: HII !> Ocean horizontal index structures for the output arrays @@ -531,24 +647,34 @@ subroutine int_density_dz(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, EOS, & !> The integral in y of the difference between the pressure anomaly at the !! top and bottom of the layer divided by the y grid spacing, in Pa. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), optional, intent(out) :: inty_dpa + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry in m + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change with the + !! same units as z_t + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. if (.not.associated(EOS)) call MOM_error(FATAL, & "int_density_dz called with an unassociated EOS_type EOS.") if (EOS%EOS_quadrature) then call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa) + EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) else ; select case (EOS%form_of_EOS) case (EOS_LINEAR) call int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & EOS%Rho_T0_S0, EOS%dRho_dT, EOS%dRho_dS, & - dpa, intz_dpa, intx_dpa, inty_dpa) + dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) case (EOS_WRIGHT) call int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - dpa, intz_dpa, intx_dpa, inty_dpa) + dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) case default call int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa) + EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) end select ; endif end subroutine int_density_dz @@ -654,7 +780,8 @@ subroutine EOS_init(param_file, EOS) units="deg C Pa-1", default=0.0) endif - if ((EOS%form_of_EOS == EOS_TEOS10 .OR. EOS%form_of_EOS == EOS_NEMO) .AND. EOS%form_of_TFreeze /= TFREEZE_TEOS10) then + if ((EOS%form_of_EOS == EOS_TEOS10 .OR. EOS%form_of_EOS == EOS_NEMO) .AND. & + EOS%form_of_TFreeze /= TFREEZE_TEOS10) then call MOM_error(FATAL, "interpret_eos_selection: EOS_TEOS10 or EOS_NEMO \n" //& "should only be used along with TFREEZE_FORM = TFREEZE_TEOS10 .") endif @@ -663,8 +790,8 @@ subroutine EOS_init(param_file, EOS) end subroutine EOS_init !> Manually initialized an EOS type (intended for unit testing of routines which need a specific EOS) -subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, Rho_T0_S0, drho_dT, & - dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) +subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & + Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) type(EOS_type), pointer :: EOS integer, optional, intent(in ) :: form_of_EOS integer, optional, intent(in ) :: form_of_TFreeze @@ -729,58 +856,67 @@ subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) end subroutine EOS_use_linear +!> This subroutine calculates (by numerical quadrature) integrals of +!! pressure anomalies across layers, which are required for calculating the +!! finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - EOS, dpa, intz_dpa, intx_dpa, inty_dpa) - type(hor_index_type), intent(in) :: HII, HIO + EOS, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HII !< Horizontal index type for input variables. + type(hor_index_type), intent(in) :: HIO !< Horizontal index type for output variables. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: T !< Potential temperature of the layer in C. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & - intent(in) :: T, S, z_t, z_b - real, intent(in) :: rho_ref, rho_0, G_e + intent(in) :: S !< Salinity of the layer in PSU. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_t !< Height at the top of the layer in m. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + intent(in) :: z_b !< Height at the bottom of the layer in m. + real, intent(in) :: rho_ref !< A mean density, in kg m-3, that is + !! subtracted out to reduce the magnitude + !! of each of the integrals. + real, intent(in) :: rho_0 !< A density, in kg m-3, that is used + !! to calculate the pressure (as p~=-z*rho_0*G_e) + !! used in the equation of state. + real, intent(in) :: G_e !< The Earth's gravitational acceleration, in m s-2. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - intent(out) :: dpa + intent(out) :: dpa !< The change in the pressure anomaly + !! across the layer, in Pa. real, dimension(HIO%isd:HIO%ied,HIO%jsd:HIO%jed), & - optional, intent(out) :: intz_dpa + optional, intent(out) :: intz_dpa !< The integral through the thickness of the + !! layer of the pressure anomaly relative to the + !! anomaly at the top of the layer, in Pa m. real, dimension(HIO%IsdB:HIO%IedB,HIO%jsd:HIO%jed), & - optional, intent(out) :: intx_dpa + optional, intent(out) :: intx_dpa !< The integral in x of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the x grid spacing, in Pa. real, dimension(HIO%isd:HIO%ied,HIO%JsdB:HIO%JedB), & - optional, intent(out) :: inty_dpa -! This subroutine calculates (by numerical quadrature) integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. The one -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! Arguments: T - potential temperature relative to the surface in C. -! (in) S - salinity in PSU. -! (in) z_t - height at the top of the layer in m. -! (in) z_b - height at the top of the layer in m. -! (in) rho_ref - A mean density, in kg m-3, that is subtracted out to reduce -! the magnitude of each of the integrals. -! (The pressure is calucated as p~=-z*rho_0*G_e.) -! (in) rho_0 - A density, in kg m-3, that is used to calculate the pressure -! (as p~=-z*rho_0*G_e) used in the equation of state. -! (in) G_e - The Earth's gravitational acceleration, in m s-2. -! (in) G - The ocean's grid structure. -! (in) EOS - type that selects the eqn of state. -! (out) dpa - The change in the pressure anomaly across the layer, -! in Pa. -! (out,opt) intz_dpa - The integral through the thickness of the layer of the -! pressure anomaly relative to the anomaly at the top of -! the layer, in Pa m. -! (out,opt) intx_dpa - The integral in x of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the x grid spacing, in Pa. -! (out,opt) inty_dpa - The integral in y of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the y grid spacing, in Pa. - + optional, intent(out) :: inty_dpa !< The integral in y of the difference between + !! the pressure anomaly at the top and bottom of the + !! layer divided by the y grid spacing, in Pa. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry in m + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change with the + !! same units as z_t + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. real :: T5(5), S5(5), p5(5), r5(5) - real :: rho_anom - real :: w_left, w_right, intz(5) + real :: rho_anom ! The depth averaged density anomaly in kg m-3. + real :: w_left, w_right real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho, I_Rho - real :: dz + real :: dz ! The layer thickness, in m. + real :: hWght ! A pressure-thickness below topography, in m. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in m. + real :: iDenom ! The inverse of the denominator in the wieghts, in m-2. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. + real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: intz(5) ! The integrals of density with height at the + ! 5 sub-column locations, in m2 s-2. + logical :: do_massWeight ! Indicates whether to do mass weighting. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, ioff, joff ioff = HIO%idg_offset - HII%idg_offset @@ -796,17 +932,25 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "bathyT must be present if useMassWghtInterp is present and true.") + if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz = z_t(i,j) - z_b(i,j) do n=1,5 T5(n) = T(i,j) ; S5(n) = S(i,j) p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref) ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - & - rho_ref + rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) dpa(i-ioff,j-joff) = G_e*dz*rho_anom ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of ! the pressure anomaly. @@ -815,22 +959,40 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - T5(1) = w_left*T(i,j) + w_right*T(i+1,j) - S5(1) = w_left*S(i,j) + w_right*S(i+1,j) - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i+1,j)) + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) - p5(n) = p5(n-1) + GxRho*0.25*dz + T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref) ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & - 12.0*r5(3)) - rho_ref) + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) enddo ! Use Bode's rule to integrate the bottom pressure anomaly values in x. intx_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & @@ -838,232 +1000,49 @@ subroutine int_density_dz_generic(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, enddo ; enddo ; endif if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i-ioff,j-joff+1) do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) - T5(1) = w_left*T(i,j) + w_right*T(i,j+1) - S5(1) = w_left*S(i,j) + w_right*S(i,j+1) - p5(1) = -GxRho*(w_left*z_t(i,j) + w_right*z_t(i,j+1)) + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + p5(1) = -GxRho*(wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) do n=2,5 T5(n) = T5(1) ; S5(n) = S5(1) p5(n) = p5(n-1) + GxRho*0.25*dz enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) + call calculate_density(T5, S5, p5, r5, 1, 5, EOS, rho_ref) ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & - 12.0*r5(3)) - rho_ref) + intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) enddo ! Use Bode's rule to integrate the values. inty_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) + 12.0*intz(3)) enddo ; enddo ; endif end subroutine int_density_dz_generic -! ============================================================================== -subroutine int_density_dz_generic_cell (T_t_arg, T_b_arg, S_t_arg, S_b_arg, & - z_t_arg, z_b_arg, depth, rho_ref, & - rho_0, G_e, EOS, dpa, & - intz_dpa, intx_dpa, inty_dpa) - - ! Arguments - real, dimension(2), intent(in) :: T_t_arg, T_b_arg, S_t_arg, S_b_arg - real, dimension(2), intent(inout) :: z_t_arg, z_b_arg - real, dimension(2), intent(in) :: depth - real, intent(in) :: rho_ref, rho_0, G_e - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(2), intent(out) :: dpa - real, dimension(2), intent(out) :: intz_dpa - real, intent(out) :: intx_dpa - real, intent(out) :: inty_dpa - - ! Local variables - real :: T_t(2), T_b(2) ! top and bottom temperatures - real :: S_t(2), S_b(2) ! top and bottom salinities - real :: z_t(2), z_b(2) ! top and bottom heights - real :: h1, h2 ! cell thicknesses - real :: T5(5), S5(5), p5(5), r5(5) ! temperature, salinity, pressure and - ! density at quadrature points - real :: rho_anom - real :: w_left, w_right, intz(5) - real :: GxRho - real :: dz - real :: weight_t, weight_b - real :: Dmin ! minimum depth - integer :: n, m - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants - - GxRho = G_e * rho_0 - - ! ------------------------------------------------------- - ! 0. Modify cell geometry to take topography into account - ! ------------------------------------------------------- - Dmin = min ( depth(1), depth(2) ) - - z_b(1) = max ( z_b_arg(1), -Dmin ) - z_b(2) = max ( z_b_arg(2), -Dmin ) - - if ( z_b(1) .GT. z_t_arg(1) ) z_b(1) = z_t_arg(1) - if ( z_b(2) .GT. z_t_arg(2) ) z_b(2) = z_t_arg(2) - - ! We do not modify the heights at the top of the cell - z_t = z_t_arg - - h1 = z_t(1) - z_b(1) - h2 = z_t(2) - z_b(2) - - ! Compute new salinities and temperatures at the bottom - S_b(1) = S_t_arg(1) + (S_b_arg(1)-S_t_arg(1)) * (h1 / (z_t_arg(1)-z_b_arg(1))) - S_b(2) = S_t_arg(2) + (S_b_arg(2)-S_t_arg(2)) * (h2 / (z_t_arg(2)-z_b_arg(2))) - - T_b(1) = T_t_arg(1) + (T_b_arg(1)-T_t_arg(1)) * (h1 / (z_t_arg(1)-z_b_arg(1))) - T_b(2) = T_t_arg(2) + (T_b_arg(2)-T_t_arg(2)) * (h2 / (z_t_arg(2)-z_b_arg(2))) - ! Temperatures and salinities at the top remain the same - S_t = S_t_arg - T_t = T_t_arg - - ! Save layer bottom interface heights for use outside this routine - z_b_arg = z_b - - ! ---------------------------------------- - ! 1. Compute left side (vertical) integral - ! ---------------------------------------- - dz = z_t(1) - z_b(1) - - do n = 1,5 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S5(n) = weight_t * S_t(1) + weight_b * S_b(1) - T5(n) = weight_t * T_t(1) + weight_b * T_b(1) - p5(n) = -GxRho*(z_t(1) - 0.25*real(n-1)*dz) - enddo - - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - - ! Use Boole's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref - dpa(1) = G_e*dz*rho_anom - - ! Use a Bode's-rule-like fifth-order accurate estimate of the - ! double integral of the pressure anomaly. - r5 = r5 - rho_ref - intz_dpa(1) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - - ! ----------------------------------------- - ! 2. Compute right side (vertical) integral - ! ----------------------------------------- - dz = z_t(2) - z_b(2) - - do n = 1,5 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S5(n) = weight_t * S_t(2) + weight_b * S_b(2) - T5(n) = weight_t * T_t(2) + weight_b * T_b(2) - p5(n) = -GxRho*(z_t(2) - 0.25*real(n-1)*dz) - enddo - - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - - ! Use Boole's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref - dpa(2) = G_e*dz*rho_anom - - ! Use a Bode's-rule-like fifth-order accurate estimate of the - ! double integral of the pressure anomaly. - r5 = r5 - rho_ref - intz_dpa(2) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - - ! ---------------------- - ! 3. Compute x-intergral - ! ---------------------- - !if (present(intx_dpa)) then - - intz(1) = dpa(1) - intz(5) = dpa(2) - - do m = 2,4 - w_left = 0.25*real(5-m) - w_right = 1.0-w_left - - dz = w_left*(z_t(1) - z_b(1)) + w_right*(z_t(2) - z_b(2)) - - T5(1) = w_left*T_t(1) + w_right*T_t(2) - T5(5) = w_left*T_b(1) + w_right*T_b(2) - - S5(1) = w_left*S_t(1) + w_right*S_t(2) - S5(5) = w_left*S_b(1) + w_right*S_b(2) - - p5(1) = -GxRho*(w_left*z_t(1) + w_right*z_t(2)) - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - - do n = 1,5 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S5(n) = weight_t * S5(1) + weight_b * S5(5) - enddo - - call calculate_density (T5, S5, p5, r5, 1, 5, EOS) - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & - 12.0*r5(3)) - rho_ref) - enddo - - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. - intx_dpa = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - !end if ! check if intx_dpa is present - - ! --------------------- - ! 4. Compute y-intergal - ! --------------------- - !if (present(inty_dpa)) then - - intz(1) = dpa(1) - intz(5) = dpa(2) - - do m=2,4 - w_left = 0.25*real(5-m) - w_right = 1.0-w_left - - dz = w_left*(z_t(1) - z_b(2)) + w_right*(z_t(1) - z_b(2)) - - S5(1) = w_left*S_t(1) + w_right*S_t(2) - S5(5) = w_left*S_b(1) + w_right*S_b(2) - S5(1) = w_left*S_t(1) + w_right*S_t(2) - S5(5) = w_left*S_b(1) + w_right*S_b(2) - p5(1) = -GxRho*(w_left*z_t(1) + w_right*z_t(2)) - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - do n=1,5 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S5(n) = weight_t * S5(1) + weight_b * S5(5) - enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - - ! Use Bode's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + & - 12.0*r5(3)) - rho_ref) - enddo - - ! Use Bode's rule to integrate the values. - inty_dpa = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & - 12.0*intz(3)) - - !end if ! check if inty_dpa is present - -end subroutine int_density_dz_generic_cell -! ============================================================================ - - ! ========================================================================== !> Compute pressure gradient force integrals by quadrature for the case where !! T and S are linear profiles. @@ -1083,7 +1062,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & !! of the layer, usually in m real, intent(in) :: rho_ref, rho_0, G_e real, intent(in) :: dz_subroundoff !< A miniscule thickness - !! change in the same units as z_t + !! change with the same units as z_t real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: bathyT !< The depth of the bathymetry in m type(EOS_type), pointer :: EOS !< Equation of state structure @@ -1141,7 +1120,6 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & real :: S5((5*HIO%iscB+1):(5*(HIO%iecB+2))) real :: p5((5*HIO%iscB+1):(5*(HIO%iecB+2))) real :: r5((5*HIO%iscB+1):(5*(HIO%iecB+2))) - real :: u5((5*HIO%iscB+1):(5*(HIO%iecB+2))) real :: T15((15*HIO%iscB+1):(15*(HIO%iecB+1))) real :: S15((15*HIO%iscB+1):(15*(HIO%iecB+1))) real :: p15((15*HIO%iscB+1):(15*(HIO%iecB+1))) @@ -1152,7 +1130,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho, I_Rho real :: dz(HIO%iscB:HIO%iecB+1), dz_x(5,HIO%iscB:HIO%iecB), dz_y(5,HIO%isc:HIO%iec) - real :: weight_t, weight_b, hWght, massWeightingToggle + real :: weight_t, weight_b, hWght, massWeightToggle real :: Ttl, Tbl, Ttr, Tbr, Stl, Sbl, Str, Sbr, hL, hR, iDenom integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n integer :: iin, jin, ioff, joff @@ -1165,9 +1143,9 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 - massWeightingToggle = 0. + massWeightToggle = 0. if (present(useMassWghtInterp)) then - if (useMassWghtInterp) massWeightingToggle = 1. + if (useMassWghtInterp) massWeightToggle = 1. endif do n = 1, 5 @@ -1189,19 +1167,17 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & T5(i*5+n) = wt_t(n) * T_t(iin,jin) + wt_b(n) * T_b(iin,jin) enddo enddo - call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS ) - u5 = r5 - rho_ref + call calculate_density_array(T5, S5, p5, r5, 1, (ieq-isq+2)*5, EOS, rho_ref ) do i=isq,ieq+1 ; iin = i+ioff ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) - & - rho_ref + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) dpa(i,j) = G_e*dz(i)*rho_anom if (present(intz_dpa)) then ! Use a Bode's-rule-like fifth-order accurate estimate of ! the double integral of the pressure anomaly. intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & - (rho_anom - C1_90*(16.0*(u5(i*5+4)-u5(i*5+2)) + 7.0*(u5(i*5+5)-u5(i*5+1))) ) + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) endif enddo enddo ! end loops on j @@ -1211,77 +1187,76 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! 2. Compute horizontal integrals in the x direction ! ================================================== if (present(intx_dpa)) then ; do j=HIO%jsc,HIO%jec ; jin = j+joff - do I=Isq,Ieq ; iin = i+ioff - - ! Corner values of T and S - ! hWght is the distance measure by which the cell is violation of - ! hydrostatic consistency. For large hWght we bias the interpolation - ! of T,S along the top and bottom integrals, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightingToggle * & - max(0., -bathyT(iin,jin)-z_t(iin+1,jin), -bathyT(iin+1,jin)-z_t(iin,jin)) - if (hWght > 0.) then - hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff - hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(iin+1,jin) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom - Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin+1,jin) ) * iDenom - Tbl = ( (hWght*hR)*T_b(iin+1,jin) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom - Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin+1,jin) ) * iDenom - Stl = ( (hWght*hR)*S_t(iin+1,jin) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom - Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin+1,jin) ) * iDenom - Sbl = ( (hWght*hR)*S_b(iin+1,jin) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom - Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin+1,jin) ) * iDenom - else - Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin+1,jin); Tbr = T_b(iin+1,jin) - Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin+1,jin); Sbr = S_b(iin+1,jin) - endif + do I=Isq,Ieq ; iin = i+ioff + ! Corner values of T and S + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(iin,jin)-z_t(iin+1,jin), -bathyT(iin+1,jin)-z_t(iin,jin)) + if (hWght > 0.) then + hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff + hR = (z_t(iin+1,jin) - z_b(iin+1,jin)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(iin+1,jin) + (hWght*hL + hR*hL)*T_t(iin,jin) ) * iDenom + Ttr = ( (hWght*hL)*T_t(iin,jin) + (hWght*hR + hR*hL)*T_t(iin+1,jin) ) * iDenom + Tbl = ( (hWght*hR)*T_b(iin+1,jin) + (hWght*hL + hR*hL)*T_b(iin,jin) ) * iDenom + Tbr = ( (hWght*hL)*T_b(iin,jin) + (hWght*hR + hR*hL)*T_b(iin+1,jin) ) * iDenom + Stl = ( (hWght*hR)*S_t(iin+1,jin) + (hWght*hL + hR*hL)*S_t(iin,jin) ) * iDenom + Str = ( (hWght*hL)*S_t(iin,jin) + (hWght*hR + hR*hL)*S_t(iin+1,jin) ) * iDenom + Sbl = ( (hWght*hR)*S_b(iin+1,jin) + (hWght*hL + hR*hL)*S_b(iin,jin) ) * iDenom + Sbr = ( (hWght*hL)*S_b(iin,jin) + (hWght*hR + hR*hL)*S_b(iin+1,jin) ) * iDenom + else + Ttl = T_t(iin,jin); Tbl = T_b(iin,jin); Ttr = T_t(iin+1,jin); Tbr = T_b(iin+1,jin) + Stl = S_t(iin,jin); Sbl = S_b(iin,jin); Str = S_t(iin+1,jin); Sbr = S_b(iin+1,jin) + endif - do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dz_x(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin+1,jin) - z_b(iin+1,jin)) + do m=2,4 + w_left = 0.25*real(5-m) ; w_right = 1.0-w_left + dz_x(m,i) = w_left*(z_t(iin,jin) - z_b(iin,jin)) + w_right*(z_t(iin+1,jin) - z_b(iin+1,jin)) - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - pos = i*15+(m-2)*5 - T15(pos+1) = w_left*Ttl + w_right*Ttr - T15(pos+5) = w_left*Tbl + w_right*Tbr + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + pos = i*15+(m-2)*5 + T15(pos+1) = w_left*Ttl + w_right*Ttr + T15(pos+5) = w_left*Tbl + w_right*Tbr - S15(pos+1) = w_left*Stl + w_right*Str - S15(pos+5) = w_left*Sbl + w_right*Sbr + S15(pos+1) = w_left*Stl + w_right*Str + S15(pos+5) = w_left*Sbl + w_right*Sbr - p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin+1,jin)) + p15(pos+1) = -GxRho*(w_left*z_t(iin,jin) + w_right*z_t(iin+1,jin)) - ! Pressure - do n=2,5 - p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) - enddo + ! Pressure + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo - ! Salinity and temperature (linear interpolation in the vertical) - do n=2,4 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) - T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + ! Salinity and temperature (linear interpolation in the vertical) + do n=2,4 + weight_t = 0.25 * real(5-n) + weight_b = 1.0 - weight_t + S15(pos+n) = weight_t * S15(pos+1) + weight_b * S15(pos+5) + T15(pos+n) = weight_t * T15(pos+1) + weight_b * T15(pos+5) + enddo enddo enddo - enddo - call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS) + call calculate_density(T15, S15, p15, r15, 1, 15*(ieq-isq+1), EOS, rho_ref) do I=Isq,Ieq ; iin = i+ioff - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) ! Use Bode's rule to estimate the pressure anomaly change. do m = 2,4 - pos = i*15+(m-2)*5 - intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3)) - rho_ref) + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) enddo ! Use Bode's rule to integrate the bottom pressure anomaly values in x. intx_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & @@ -1301,7 +1276,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & ! weighting. ! Note: To work in terrain following coordinates we could offset ! this distance by the layer thickness to replicate other models. - hWght = massWeightingToggle * & + hWght = massWeightToggle * & max(0., -bathyT(i,j)-z_t(iin,jin+1), -bathyT(i,j+1)-z_t(iin,jin)) if (hWght > 0.) then hL = (z_t(iin,jin) - z_b(iin,jin)) + dz_subroundoff @@ -1352,7 +1327,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & enddo call calculate_density_array(T15(15*HIO%isc+1:), S15(15*HIO%isc+1:), p15(15*HIO%isc+1:), & - r15(15*HIO%isc+1:), 1, 15*(HIO%iec-HIO%isc+1), EOS) + r15(15*HIO%isc+1:), 1, 15*(HIO%iec-HIO%isc+1), EOS, rho_ref) do i=HIO%isc,HIO%iec ; iin = i+ioff intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) @@ -1361,7 +1336,7 @@ subroutine int_density_dz_generic_plm (T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, & pos = i*15+(m-2)*5 intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & 32.0*(r15(pos+2)+r15(pos+4)) + & - 12.0*r15(pos+3)) - rho_ref) + 12.0*r15(pos+3))) enddo ! Use Bode's rule to integrate the values. inty_dpa(i,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & @@ -1445,7 +1420,8 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t 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 +!> Returns change in anomalous pressure change from top to non-dimensional +!! position pos between z_t and z_b 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, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos type(EOS_type), pointer :: EOS !< Equation of state structure @@ -1599,7 +1575,7 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & !rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - & ! rho_ref - rho_anom = 1000.0 + S(i,j) - rho_ref; + rho_anom = 1000.0 + S(i,j) - rho_ref dpa(i-ioff,j-joff) = G_e*dz*rho_anom ! Use a Bode's-rule-like fifth-order accurate estimate of @@ -1704,10 +1680,10 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) - call calculate_density ( T_node, S_node, p_node, r_node, 1, 9, EOS ) + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS ) r_node = r_node - rho_ref - call compute_integral_quadratic ( x, y, r_node, intx_dpa(i-ioff,j-joff) ) + call compute_integral_quadratic( x, y, r_node, intx_dpa(i-ioff,j-joff) ) intx_dpa(i-ioff,j-joff) = intx_dpa(i-ioff,j-joff) * G_e @@ -1728,245 +1704,6 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & end subroutine int_density_dz_generic_ppm -! ========================================================================== -! Compute pressure gradient force integrals for the case where T and S -! are linear profiles (analytical !!) -! ========================================================================== -subroutine int_density_dz_generic_plm_analytic (T_t, T_b, S_t, S_b, z_t, & - z_b, rho_ref, rho_0, G_e, HI, EOS, dpa, intz_dpa, intx_dpa, inty_dpa) - - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T_t, T_b, S_t, S_b, z_t, z_b - real, intent(in) :: rho_ref, rho_0, G_e - type(EOS_type), pointer :: EOS !< Equation of state structure - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(out) :: dpa - real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(out) :: intz_dpa - real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(out) :: intx_dpa - real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(out) :: inty_dpa -! This subroutine calculates (by numerical quadrature) integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. The one -! potentially dodgy assumtion here is that rho_0 is used both in the denominator -! of the accelerations, and in the pressure used to calculated density (the -! latter being -z*rho_0*G_e). These two uses could be separated if need be. -! -! It is assumed that the salinity and temperature profiles are linear in the -! vertical. The top and bottom values within each layer are provided and -! a linear interpolation is used to compute intermediate values. -! -! Arguments: T - potential temperature relative to the surface in C -! (the 't' and 'b' subscripts refer to the values at -! the top and the bottom of each layer) -! (in) S - salinity in PSU. -! (the 't' and 'b' subscripts refer to the values at -! the top and the bottom of each layer) -! (in) z_t - height at the top of the layer in m. -! (in) z_b - height at the top of the layer in m. -! (in) rho_ref - A mean density, in kg m-3, that is subtracted out to reduce -! the magnitude of each of the integrals. -! (The pressure is calucated as p~=-z*rho_0*G_e.) -! (in) rho_0 - A density, in kg m-3, that is used to calculate the pressure -! (as p~=-z*rho_0*G_e) used in the equation of state. -! (in) G_e - The Earth's gravitational acceleration, in m s-2. -! (in) HI - The ocean's horizontal index structure. -! (in) form_of_eos - integer that selects the eqn of state. -! (out) dpa - The change in the pressure anomaly across the layer, -! in Pa. -! (out,opt) intz_dpa - The integral through the thickness of the layer of the -! pressure anomaly relative to the anomaly at the top of -! the layer, in Pa m. -! (out,opt) intx_dpa - The integral in x of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the x grid spacing, in Pa. -! (out,opt) inty_dpa - The integral in y of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the y grid spacing, in Pa. - - real :: T5(5), S5(5), p5(5), r5(5) - real :: rho_anom - real :: w_left, w_right, intz(5) - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho, I_Rho - real :: dz, dS - real :: weight_t, weight_b - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n - - real, dimension(4) :: x, y, f - - Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB - - call MOM_error(FATAL, "I believe that int_density_dz_generic_plm_analytic "//& - "has serious bugs and should not be used in its current form. - R. Hallberg") - - GxRho = G_e * rho_0 - I_Rho = 1.0 / rho_0 - - ! ============================= - ! 1. Compute vertical integrals - ! ============================= - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - dS = S_t(i,j) - S_b(i,j) - do n=1,5 - weight_t = 0.25 * real(5-n) - weight_b = 1.0 - weight_t - - p5(n) = -GxRho*(z_t(i,j) - 0.25*real(n-1)*dz) - - ! Salinity and temperature points are linearly interpolated - S5(n) = weight_t * S_t(i,j) + weight_b * S_b(i,j) - T5(n) = weight_t * T_t(i,j) + weight_b * T_b(i,j) - enddo - - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - - ! Use Bode's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - & - rho_ref - dpa(i,j) = G_e*dz*rho_anom - - ! Pressure anomaly change (computed analytically based on linear EOS) - rho_anom = 1000.0 + S_b(i,j) + 0.5 * dS - rho_ref - dpa(i,j) = G_e * dz * rho_anom - - ! Use a Bode's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - r5 = r5 - rho_ref - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - - - !### The fact that this this expression does not use T and that - !### an optional variable is assigned, even if it is not present - !### strongly suggests that this code is wrong. - intz_dpa(i,j) = ( 0.5 * (S_b(i,j)+1000.0-rho_ref) + & - (1.0/3.0) * dS ) * G_e * dz**2 - - enddo ; enddo ! end loops on j and i - - ! ================================================== - ! 2. Compute horizontal integrals in the x direction - ! ================================================== - if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - - ! Use Gauss quadrature rule to compute integral - x(1) = 1.0 - x(2) = 0.0 - x(3) = 0.0 - x(4) = 1.0 - y(1) = z_t(i+1,j) - y(2) = z_t(i,j) - y(3) = z_b(i,j) - y(4) = z_b(i+1,j) - f(1) = 1000.0 + S_t(i+1,j) - rho_ref - f(2) = 1000.0 + S_t(i,j) - rho_ref - f(3) = 1000.0 + S_b(i,j) - rho_ref - f(4) = 1000.0 + S_b(i+1,j) - rho_ref - - call compute_integral_bilinear ( x, y, f, intx_dpa(i,j) ) - - intx_dpa(i,j) = intx_dpa(i,j) * G_e - - enddo ; enddo ; endif - - ! ================================================== - ! 3. Compute horizontal integrals in the y direction - ! ================================================== - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - - ! Use Gauss quadrature rule to compute integral - x(1) = 1.0 - x(2) = 0.0 - x(3) = 0.0 - x(4) = 1.0 - y(1) = z_t(i,j+1) - y(2) = z_t(i,j) - y(3) = z_b(i,j) - y(4) = z_b(i,j+1) - f(1) = 1000.0 + S_t(i,j+1) - rho_ref - f(2) = 1000.0 + S_t(i,j) - rho_ref - f(3) = 1000.0 + S_b(i,j) - rho_ref - f(4) = 1000.0 + S_b(i,j+1) - rho_ref - - call compute_integral_bilinear ( x, y, f, inty_dpa(i,j) ) - - inty_dpa(i,j) = inty_dpa(i,j) * G_e - - enddo ; enddo ; endif - -end subroutine int_density_dz_generic_plm_analytic - - -! ============================================================================= -! Compute integral of bilinear function -! ============================================================================= -subroutine compute_integral_bilinear ( x, y, f, integral ) - - ! Arguments - real, intent(in), dimension(4) :: x, y, f - real, intent(out) :: integral - - ! Local variables - integer :: i, k - real, dimension(4) :: weight, xi, eta ! integration points - real :: f_k - real :: dxdxi, dxdeta - real :: dydxi, dydeta - real, dimension(4) :: phi, dphidxi, dphideta - real :: jacobian_k - - ! Quadrature rule - weight(:) = 1.0 - xi(1) = - sqrt(3.0) / 3.0 - xi(2) = sqrt(3.0) / 3.0 - xi(3) = sqrt(3.0) / 3.0 - xi(4) = - sqrt(3.0) / 3.0 - eta(1) = - sqrt(3.0) / 3.0 - eta(2) = - sqrt(3.0) / 3.0 - eta(3) = sqrt(3.0) / 3.0 - eta(4) = sqrt(3.0) / 3.0 - - integral = 0.0 - - ! Integration loop - do k = 1,4 - - ! Evaluate shape functions and gradients - call evaluate_shape_bilinear ( xi(k), eta(k), phi, dphidxi, dphideta ) - - ! Determine gradient of global coordinate at integration point - dxdxi = 0.0 - dxdeta = 0.0 - dydxi = 0.0 - dydeta = 0.0 - - do i = 1,4 - dxdxi = dxdxi + x(i) * dphidxi(i) - dxdeta = dxdeta + x(i) * dphideta(i) - dydxi = dydxi + y(i) * dphidxi(i) - dydeta = dydeta + y(i) * dphideta(i) - enddo - - ! Evaluate Jacobian at integration point - jacobian_k = dxdxi*dydeta - dydxi*dxdeta - - ! Evaluate function at integration point - f_k = 0.0 - do i = 1,4 - f_k = f_k + f(i) * phi(i) - enddo - - integral = integral + weight(k) * f_k * jacobian_k - - enddo ! end integration loop - -end subroutine compute_integral_bilinear - ! ============================================================================= ! Compute integral of quadratic function @@ -2018,8 +1755,8 @@ subroutine compute_integral_quadratic ( x, y, f, integral ) do k = 1,9 ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear ( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) + call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & + dphiisodxi, dphiisodeta ) ! Determine gradient of global coordinate at integration point dxdxi = 0.0 @@ -2038,7 +1775,7 @@ subroutine compute_integral_quadratic ( x, y, f, integral ) jacobian_k = dxdxi*dydeta - dydxi*dxdeta ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic ( xi(k), eta(k), phi, dphidxi, dphideta ) + call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) ! Evaluate function at integration point f_k = 0.0 @@ -2151,57 +1888,73 @@ subroutine evaluate_shape_quadratic ( xi, eta, phi, dphidxi, dphideta ) end subroutine evaluate_shape_quadratic ! ============================================================================== +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Bode's rule quadrature to do the integrals. subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & - dza, intp_dza, intx_dza, inty_dza, halo_size) - type(hor_index_type), intent(in) :: HI + dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_neglect, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(in) :: T, S, p_t, p_b - real, intent(in) :: alpha_ref + intent(in) :: T !< Potential temperature of the layer in C. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S !< Salinity of the layer in PSU. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure atop the layer in Pa. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure below the layer in Pa. + real, intent(in) :: alpha_ref !< A mean specific volume that is + !! subtracted out to reduce the magnitude of each of the + !! integrals, in m3 kg-1. The calculation is mathematically + !! identical with different values of alpha_ref, but alpha_ref + !! alters the effects of roundoff, and answers do change. type(EOS_type), pointer :: EOS !< Equation of state structure real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - intent(out) :: dza + intent(out) :: dza !< The change in the geopotential anomaly + !! across the layer, in m2 s-2. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & - optional, intent(out) :: intp_dza + optional, intent(out) :: intp_dza !< The integral in pressure through the + !! layer of the geopotential anomaly relative to the anomaly + !! at the bottom of the layer, in Pa m2 s-2. real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & - optional, intent(out) :: intx_dza + optional, intent(out) :: intx_dza !< The integral in x of the difference + !! between the geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing, in m2 s-2. real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & - optional, intent(out) :: inty_dza - integer, optional, intent(in) :: halo_size + optional, intent(out) :: inty_dza !< The integral in y of the difference + !! between the geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing, in m2 s-2. + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry in Pa + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t (Pa?) + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for ! calculating the finite-volume form pressure accelerations in a non-Boussinesq ! model. There are essentially no free assumptions, apart from the use of ! Bode's rule to do the horizontal integrals, and from a truncation in the ! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. -! -! Arguments: T - potential temperature relative to the surface in C. -! (in) S - salinity in PSU. -! (in) p_t - pressure at the top of the layer in Pa. -! (in) p_b - pressure at the top of the layer in Pa. -! (in) alpha_ref - A mean specific volume that is subtracted out to reduce -! the magnitude of each of the integrals, m3 kg-1. -! The calculation is mathematically identical with -! different values of alpha_ref, but this reduces the -! effects of roundoff. -! (in) HI - The ocean's horizontal index structure. -! (in) EOS - type that selects the eqn of state. -! (out) dza - The change in the geopotential anomaly across the layer, -! in m2 s-2. -! (out,opt) intp_dza - The integral in pressure through the layer of the -! geopotential anomaly relative to the anomaly at the -! bottom of the layer, in Pa m2 s-2. -! (out,opt) intx_dza - The integral in x of the difference between the -! geopotential anomaly at the top and bottom of the layer -! divided by the x grid spacing, in m2 s-2. -! (out,opt) inty_dza - The integral in y of the difference between the -! geopotential anomaly at the top and bottom of the layer -! divided by the y grid spacing, in m2 s-2. -! (in,opt) halo_size - The width of halo points on which to calculate dza. - real :: T5(5), S5(5), p5(5), r5(5), a5(5) - real :: alpha_anom - real :: w_left, w_right, intp(5) - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. - real :: dp ! The pressure change through each layer, in Pa. + + real :: T5(5), S5(5), p5(5), a5(5) + real :: alpha_anom ! The depth averaged specific density anomaly in m3 kg-1. + real :: dp ! The pressure change through a layer, in Pa. +! real :: dp_90(2:4) ! The pressure change through a layer divided by 90, in Pa. + real :: hWght ! A pressure-thickness below topography, in Pa. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in Pa. + real :: iDenom ! The inverse of the denominator in the wieghts, in Pa-2. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. + real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations, in m2 s-2. + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB @@ -2210,73 +1963,350 @@ subroutine int_spec_vol_dp_generic(T, S, p_t, p_b, alpha_ref, HI, EOS, & if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "bathyP must be present if useMassWghtInterp is present and true.") + if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& + "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + do j=jsh,jeh ; do i=ish,ieh dp = p_b(i,j) - p_t(i,j) do n=1,5 T5(n) = T(i,j) ; S5(n) = S(i,j) p5(n) = p_b(i,j) - 0.25*real(n-1)*dp enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - do n=1,5 ; a5(n) = 1.0 / r5(n) ; enddo + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref) - ! Use Bode's rule to estimate the pressure anomaly change. - alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) - & - alpha_ref + ! Use Bode's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) dza(i,j) = dp*alpha_anom ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of - ! the pressure anomaly. + ! the interface height anomaly. if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) enddo ; enddo if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dp = w_left*(p_b(i,j) - p_t(i,j)) + w_right*(p_b(i+1,j) - p_t(i+1,j)) - T5(1) = w_left*T(i,j) + w_right*T(i+1,j) - S5(1) = w_left*S(i,j) + w_right*S(i+1,j) - p5(1) = w_left*p_b(i,j) + w_right*p_b(i+1,j) + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness wekghted. + p5(1) = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + do n=2,5 T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - 0.25*dp enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - do n=1,5 ; a5(n) = 1.0 / r5(n) ; enddo + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref) - ! Use Bode's rule to estimate the pressure anomaly change. + ! Use Bode's rule to estimate the interface height anomaly change. intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3)) - alpha_ref) + 12.0*a5(3))) enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in x. + ! Use Bode's rule to integrate the interface height anomaly values in x. intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & 12.0*intp(3)) enddo ; enddo ; endif if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - dp = w_left*(p_b(i,j) - p_t(i,j)) + w_right*(p_b(i,j+1) - p_t(i,j+1)) - T5(1) = w_left*T(i,j) + w_right*T(i,j+1) - S5(1) = w_left*S(i,j) + w_right*S(i,j+1) - p5(1) = w_left*p_b(i,j) + w_right*p_b(i,j+1) + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness wekghted. + p5(1) = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) do n=2,5 T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - 0.25*dp enddo - call calculate_density(T5, S5, p5, r5, 1, 5, EOS) - do n=1,5 ; a5(n) = 1.0 / r5(n) ; enddo + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref) - ! Use Bode's rule to estimate the pressure anomaly change. + ! Use Bode's rule to estimate the interface height anomaly change. intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3)) - alpha_ref) + 12.0*a5(3))) enddo - ! Use Bode's rule to integrate the bottom pressure anomaly values in y. + ! Use Bode's rule to integrate the interface height anomaly values in y. inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & 12.0*intp(3)) enddo ; enddo ; endif end subroutine int_spec_vol_dp_generic +!> This subroutine calculates integrals of specific volume anomalies in +!! pressure across layers, which are required for calculating the finite-volume +!! form pressure accelerations in a non-Boussinesq model. There are essentially +!! no free assumptions, apart from the use of Bode's rule quadrature to do the integrals. +subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, & + dP_neglect, bathyP, HI, EOS, dza, & + intp_dza, intx_dza, inty_dza, useMassWghtInterp) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_t !< Potential temperature at the top of the layer in C. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: T_b !< Potential temperature at the bottom of the layer in C. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S_t !< Salinity at the top the layer in PSU. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: S_b !< Salinity at the bottom the layer in PSU. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_t !< Pressure atop the layer in Pa. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: p_b !< Pressure below the layer in Pa. + real, intent(in) :: alpha_ref !< A mean specific volume that is + !! subtracted out to reduce the magnitude of each of the + !! integrals, in m3 kg-1. The calculation is mathematically + !! identical with different values of alpha_ref, but alpha_ref + !! alters the effects of roundoff, and answers do change. + real, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t (Pa?) + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(in) :: bathyP !< The pressure at the bathymetry in Pa + type(EOS_type), pointer :: EOS !< Equation of state structure + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + intent(out) :: dza !< The change in the geopotential anomaly + !! across the layer, in m2 s-2. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(out) :: intp_dza !< The integral in pressure through the + !! layer of the geopotential anomaly relative to the anomaly + !! at the bottom of the layer, in Pa m2 s-2. + real, dimension(HI%IsdB:HI%IedB,HI%jsd:HI%jed), & + optional, intent(out) :: intx_dza !< The integral in x of the difference + !! between the geopotential anomaly at the top and bottom of + !! the layer divided by the x grid spacing, in m2 s-2. + real, dimension(HI%isd:HI%ied,HI%JsdB:HI%JedB), & + optional, intent(out) :: inty_dza !< The integral in y of the difference + !! between the geopotential anomaly at the top and bottom of + !! the layer divided by the y grid spacing, in m2 s-2. + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. + +! This subroutine calculates analytical and nearly-analytical integrals in +! pressure across layers of geopotential anomalies, which are required for +! calculating the finite-volume form pressure accelerations in a non-Boussinesq +! model. There are essentially no free assumptions, apart from the use of +! Bode's rule to do the horizontal integrals, and from a truncation in the +! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. + + real, dimension(5) :: T5, S5, p5, a5 + real, dimension(15) :: T15, S15, p15, a15 + real :: wt_t(5), wt_b(5) + real :: T_top, T_bot, S_top, S_bot, P_top, P_bot + + real :: alpha_anom ! The depth averaged specific density anomaly in m3 kg-1. + real :: dp ! The pressure change through a layer, in Pa. + real :: dp_90(2:4) ! The pressure change through a layer divided by 90, in Pa. + real :: hWght ! A pressure-thickness below topography, in Pa. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in Pa. + real :: iDenom ! The inverse of the denominator in the wieghts, in Pa-2. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. + real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations, in m2 s-2. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. + logical :: do_massWeight ! Indicates whether to do mass weighting. + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos + + Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB + + do_massWeight = .false. + if (present(useMassWghtInterp)) do_massWeight = useMassWghtInterp + + do n = 1, 5 ! Note that these are reversed from int_density_dz. + wt_t(n) = 0.25 * real(n-1) + wt_b(n) = 1.0 - wt_t(n) + enddo + + ! ============================= + ! 1. Compute vertical integrals + ! ============================= + do j=Jsq,Jeq+1; do i=Isq,Ieq+1 + dp = p_b(i,j) - p_t(i,j) + do n=1,5 ! T, S and p are linearly interpolated in the vertical. + p5(n) = wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j) + S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + enddo + call calculate_spec_vol(T5, S5, p5, a5, 1, 5, EOS, alpha_ref) + + ! Use Bode's rule to estimate the interface height anomaly change. + alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) + dza(i,j) = dp*alpha_anom + ! Use a Bode's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) + enddo ; enddo + + ! ================================================== + ! 2. Compute horizontal integrals in the x direction + ! ================================================== + if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, almost like thickness + ! weighting. Note: To work in terrain following coordinates we could + ! offset this distance by the layer thickness to replicate other models. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness wekghted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref) + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + ! Use Bode's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Bode's rule to integrate the interface height anomaly values in x. + intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + + ! ================================================== + ! 3. Compute horizontal integrals in the y direction + ! ================================================== + if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation + ! of T,S along the top and bottom integrals, like thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness wekghted. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) + dp_90(m) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = (m-2)*5 + do n=1,5 + p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo + enddo + + call calculate_spec_vol(T15, S15, p15, a15, 1, 15, EOS, alpha_ref) + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + ! Use Bode's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = (m-2)*5 + intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Bode's rule to integrate the interface height anomaly values in x. + inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) + enddo ; enddo ; endif + +end subroutine int_spec_vol_dp_generic_plm + !> Convert T&S to Absolute Salinity and Conservative Temperature if using TEOS10 subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) use MOM_grid, only : ocean_grid_type @@ -2302,21 +2332,21 @@ subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) if (.not.associated(EOS)) call MOM_error(FATAL, & "convert_temp_salt_to_TEOS10 called with an unassociated EOS_type EOS.") - if ((EOS%form_of_EOS .ne. EOS_TEOS10) .and. (EOS%form_of_EOS .ne. EOS_NEMO)) return + if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return do k=1,kd ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (mask_z(i,j,k) .ge. 1.0) then + if (mask_z(i,j,k) >= 1.0) then S(i,j,k) = gsw_sr_from_sp(S(i,j,k)) ! p=press(k)/10000. !convert pascal to dbar ! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),p,G%geoLonT(i,j),G%geoLatT(i,j)) T(i,j,k) = gsw_ct_from_pt(S(i,j,k),T(i,j,k)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 ! Extractor routine for the EOS type if the members need to be accessed outside this module -subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, Rho_T0_S0, drho_dT, & - dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) +subroutine extract_member_EOS(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & + Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) type(EOS_type), pointer :: EOS integer, optional, intent(out) :: form_of_EOS integer, optional, intent(out) :: form_of_TFreeze diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index da67dd2e0a..86ad3cb5be 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -167,19 +167,16 @@ module MOM_EOS_NEMO contains -subroutine calculate_density_scalar_nemo(T, S, pressure, rho) -real, intent(in) :: T, S, pressure -real, intent(out) :: rho -! * Arguments: T - conservative temperature in C. * -! * (in) S - absoulte salinity in g/Kg. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * - -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) from absolute salinity (S in g/Kg), conservative * -! * temperature (T in deg C), and pressure in Pa. * -! *====================================================================* +!> This subroutine computes the in situ density of sea water (rho in +!! units of kg/m^3) from absolute salinity (S in g/kg), conservative temperature +!! (T in deg C), and pressure in Pa. It uses the expressions derived for use +!! with NEMO. +subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) + real, intent(in) :: T !< Conservative temperature in C. + real, intent(in) :: S !< Absolute salinity in g/kg. + real, intent(in) :: pressure !< Pressure in Pa. + real, intent(out) :: rho !< In situ density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. real :: al0, p0, lambda integer :: j @@ -190,39 +187,31 @@ subroutine calculate_density_scalar_nemo(T, S, pressure, rho) S0(1) = S pressure0(1) = pressure - call calculate_density_array_nemo(T0, S0, pressure0, rho0, 1, 1) + call calculate_density_array_nemo(T0, S0, pressure0, rho0, 1, 1, rho_ref) rho = rho0(1) + end subroutine calculate_density_scalar_nemo -!> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from absolute salinity (S in g/Kg), -!! conservative temperature (T in deg C), and pressure in Pa. -subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts) - real, intent(in), dimension(:) :: T !< Conservative temperature in C. - real, intent(in), dimension(:) :: S !< Absoulte salinity in g/Kg. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: rho !< In situ density in kg m-3. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. -! * Arguments: T - conservative temperature in C. * -! * (in) S - absoulte salinity in g/Kg. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * +!> This subroutine computes the in situ density of sea water (rho in +!! units of kg/m^3) from absolute salinity (S in g/kg), conservative temperature +!! (T in deg C), and pressure in Pa. It uses the expressions derived for use +!! with NEMO. +subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_ref) + real, dimension(:), intent(in) :: T !< Conservative temperature in C. + real, dimension(:), intent(in) :: S !< Absolute salinity in g/kg + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) from absolute salinity (S in g/Kg), * -! * conservative temperature (T in deg C), and pressure in Pa. * -! *====================================================================* - real :: zp,zt , zh , zs , zr0, zn , zn0, zn1, zn2, zn3 + real :: zp, zt, zh, zs, zr0, zn, zn0, zn1, zn2, zn3, zs0 integer :: j do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp + zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar !The following algorithm was provided by Roquet in a private communication. @@ -230,33 +219,38 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts) zp = zp * r1_P0 !pressure zt = zt * r1_T0 !temperature zs = SQRT( ABS( zs + rdeltaS ) * r1_S0 ) ! square root salinity - ! + zn3 = EOS013*zt & & + EOS103*zs+EOS003 - ! + zn2 = (EOS022*zt & & + EOS112*zs+EOS012)*zt & & + (EOS202*zs+EOS102)*zs+EOS002 - ! + zn1 = (((EOS041*zt & & + EOS131*zs+EOS031)*zt & & + (EOS221*zs+EOS121)*zs+EOS021)*zt & & + ((EOS311*zs+EOS211)*zs+EOS111)*zs+EOS011)*zt & & + (((EOS401*zs+EOS301)*zs+EOS201)*zs+EOS101)*zs+EOS001 - ! + zn0 = (((((EOS060*zt & & + EOS150*zs+EOS050)*zt & & + (EOS240*zs+EOS140)*zs+EOS040)*zt & & + ((EOS330*zs+EOS230)*zs+EOS130)*zs+EOS030)*zt & & + (((EOS420*zs+EOS320)*zs+EOS220)*zs+EOS120)*zs+EOS020)*zt & - & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt & - & + (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs+EOS000 - ! - zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + zn0 - ! + & + ((((EOS510*zs+EOS410)*zs+EOS310)*zs+EOS210)*zs+EOS110)*zs+EOS010)*zt + + zs0 = (((((EOS600*zs+EOS500)*zs+EOS400)*zs+EOS300)*zs+EOS200)*zs+EOS100)*zs + EOS000 + zr0 = (((((R05 * zp+R04) * zp+R03 ) * zp+R02 ) * zp+R01) * zp+R00) * zp - ! - rho(j) = ( zn + zr0 ) ! density + + if (present(rho_ref)) then + zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + (zn0 + (zs0 - rho_ref)) + rho(j) = ( zn + zr0 ) ! density + else + zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + (zn0 + zs0) + rho(j) = ( zn + zr0 ) ! density + endif enddo end subroutine calculate_density_array_nemo diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index 5c12afafac..ce940ca26f 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -8,13 +8,14 @@ module MOM_EOS_TEOS10 !*********************************************************************** use gsw_mod_toolbox, only : gsw_sp_from_sr, gsw_pt_from_ct -use gsw_mod_toolbox, only : gsw_rho, gsw_rho_first_derivatives, gsw_specvol_first_derivatives +use gsw_mod_toolbox, only : gsw_rho, gsw_specvol +use gsw_mod_toolbox, only : gsw_rho_first_derivatives, gsw_specvol_first_derivatives use gsw_mod_toolbox, only : gsw_rho_second_derivatives !use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt implicit none ; private -public calculate_compress_teos10, calculate_density_teos10 +public calculate_compress_teos10, calculate_density_teos10, calculate_spec_vol_teos10 public calculate_density_derivs_teos10 public calculate_specvol_derivs_teos10 public calculate_density_second_derivs_teos10 @@ -24,6 +25,10 @@ module MOM_EOS_TEOS10 module procedure calculate_density_scalar_teos10, calculate_density_array_teos10 end interface calculate_density_teos10 +interface calculate_spec_vol_teos10 + module procedure calculate_spec_vol_scalar_teos10, calculate_spec_vol_array_teos10 +end interface calculate_spec_vol_teos10 + interface calculate_density_derivs_teos10 module procedure calculate_density_derivs_scalar_teos10, calculate_density_derivs_array_teos10 end interface calculate_density_derivs_teos10 @@ -37,27 +42,15 @@ module MOM_EOS_TEOS10 contains !> This subroutine computes the in situ density of sea water (rho in -!! units of kg/m^3) from salinity (S in psu), potential temperature -!! (T in deg C), and pressure in Pa. It uses the expression from +!! units of kg/m^3) from absolute salinity (S in g/kg), conservative temperature +!! (T in deg C), and pressure in Pa. It uses the expression from the !! TEOS10 website. -subroutine calculate_density_scalar_teos10(T, S, pressure, rho) -real, intent(in) :: T !< Conservative temperature in C. -real, intent(in) :: S !< Absolute salinity in g/kg. -real, intent(in) :: pressure !< Pressure in Pa. -real, intent(out) :: rho !< In situ density in kg m-3. -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * - -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) from salinity (S in psu), potential temperature * -! * (T in deg C), and pressure in Pa. It uses the expression from * -! * TEOS10 website. * -! *====================================================================* +subroutine calculate_density_scalar_teos10(T, S, pressure, rho, rho_ref) + real, intent(in) :: T !< Conservative temperature in C. + real, intent(in) :: S !< Absolute salinity in g/kg. + real, intent(in) :: pressure !< Pressure in Pa. + real, intent(out) :: rho !< In situ density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. real, dimension(1) :: T0, S0, pressure0 real, dimension(1) :: rho0 @@ -66,29 +59,25 @@ subroutine calculate_density_scalar_teos10(T, S, pressure, rho) S0(1) = S pressure0(1) = pressure - call calculate_density_array_teos10(T0, S0, pressure0, rho0, 1, 1) + call calculate_density_array_teos10(T0, S0, pressure0, rho0, 1, 1, rho_ref) rho = rho0(1) end subroutine calculate_density_scalar_teos10 -subroutine calculate_density_array_teos10(T, S, pressure, rho, start, npts) - real, intent(in), dimension(:) :: T, S, pressure - real, intent(out), dimension(:) :: rho - integer, intent(in) :: start, npts -! * Arguments: T - conservative temperature in C. * -! * (in) S - absolute salinity in g/kg. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * +!> This subroutine computes the in situ density of sea water (rho in +!! units of kg/m^3) from absolute salinity (S in g/kg), conservative temperature +!! (T in deg C), and pressure in Pa. It uses the expression from the +!! TEOS10 website. +subroutine calculate_density_array_teos10(T, S, pressure, rho, start, npts, rho_ref) + real, dimension(:), intent(in) :: T !< Conservative temperature in C. + real, dimension(:), intent(in) :: S !< Absolute salinity in g/kg + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) from absolute salinity (S in g/Kg), * -! * conservative temperature (T in deg C), and pressure in Pa. * -! * It uses the functions from TEOS10 website * -! *====================================================================* - real :: zs,zt,zp + real :: zs, zt, zp integer :: j do j=start,start+npts-1 @@ -97,11 +86,70 @@ subroutine calculate_density_array_teos10(T, S, pressure, rho, 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 - if(S(j).lt.-1.0e-10) cycle !Can we assume safely that this is a missing value? - rho(j) = gsw_rho(zs,zt,zp) - enddo + if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? + rho(j) = 1000.0 + else + rho(j) = gsw_rho(zs,zt,zp) + endif + if (present(rho_ref)) rho(j) = rho(j) - rho_ref + enddo end subroutine calculate_density_array_teos10 +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) +!! and pressure in Pa, using the TEOS10 equation of state. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_scalar_teos10(T, S, pressure, specvol, spv_ref) + real, intent(in) :: T !< potential temperature relative to the surface + !! in C. + real, intent(in) :: S !< salinity in PSU. + real, intent(in) :: pressure !< pressure in Pa. + real, intent(out) :: specvol !< in situ specific volume in m3 kg-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + + real, dimension(1) :: T0, S0, pressure0, spv0 + + T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + + call calculate_spec_vol_array_teos10(T0, S0, pressure0, spv0, 1, 1, spv_ref) + specvol = spv0(1) +end subroutine calculate_spec_vol_scalar_teos10 + + +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) +!! and pressure in Pa, using the TEOS10 equation of state. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_array_teos10(T, S, pressure, specvol, start, npts, spv_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface + !! in C. + real, dimension(:), intent(in) :: S !< salinity in PSU. + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: specvol !< in situ specific volume in m3 kg-1. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + + real :: zs, zt, zp + integer :: j + + do j=start,start+npts-1 + !Conversions + zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity + 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 + + if (S(j) < -1.0e-10) then + specvol(j) = 0.001 !Can we assume safely that this is a missing value? + else + specvol(j) = gsw_specvol(zs,zt,zp) + endif + if (present(spv_ref)) specvol(j) = specvol(j) - spv_ref + enddo + +end subroutine calculate_spec_vol_array_teos10 + + subroutine calculate_density_derivs_array_teos10(T, S, pressure, drho_dT, drho_dS, start, npts) real, intent(in), dimension(:) :: T !< Conservative temperature in C. real, intent(in), dimension(:) :: S !< Absolute salinity in g/kg. @@ -129,8 +177,11 @@ subroutine calculate_density_derivs_array_teos10(T, S, pressure, drho_dT, drho_d zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity 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 - if(S(j).lt.-1.0e-10) cycle !Can we assume safely that this is a missing value? - call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS(j), drho_dct=drho_dT(j)) + if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? + drho_dT(j) = 0.0 ; drho_dS(j) = 0.0 + else + call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS(j), drho_dct=drho_dT(j)) + endif enddo end subroutine calculate_density_derivs_array_teos10 @@ -144,7 +195,7 @@ subroutine calculate_density_derivs_scalar_teos10(T, S, pressure, drho_dT, drho_ zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if(S.lt.-1.0e-10) return !Can we assume safely that this is a missing value? + if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) end subroutine calculate_density_derivs_scalar_teos10 @@ -175,15 +226,18 @@ subroutine calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity 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 - if(S(j).lt.-1.0e-10) cycle !Can we assume safely that this is a missing value? - call gsw_specvol_first_derivatives(zs,zt,zp, v_sa=dSV_dS(j), v_ct=dSV_dT(j)) + if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? + dSV_dT(j) = 0.0 ; dSV_dS(j) = 0.0 + else + call gsw_specvol_first_derivatives(zs,zt,zp, v_sa=dSV_dS(j), v_ct=dSV_dT(j)) + endif enddo end subroutine calculate_specvol_derivs_teos10 !> Calculate the 5 second derivatives of the equation of state for scalar inputs -subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP) +subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) real, intent(in) :: T, S, pressure real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S real, intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T @@ -203,15 +257,15 @@ subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, drho_dS zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if(S.lt.-1.0e-10) return !Can we assume safely that this is a missing value? + if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) end subroutine calculate_density_second_derivs_scalar_teos10 !> Calculate the 5 second derivatives of the equation of state for scalar inputs -subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, & - drho_dT_dP, start, npts) +subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, start, npts) real, dimension(:), intent(in) :: T, S, pressure real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect to S real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T @@ -234,9 +288,13 @@ subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_ zs = S(j) !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T(j) !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if(zs .lt. -1.0e-10) return !Can we assume safely that this is a missing value? - call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS(j), rho_sa_ct=drho_dS_dT(j), & - rho_ct_ct=drho_dT_dT(j), rho_sa_p=drho_dS_dP(j), rho_ct_p=drho_dT_dP(j)) + if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? + drho_dS_dS(j) = 0.0 ; drho_dS_dT(j) = 0.0 ; drho_dT_dT(j) = 0.0 + drho_dS_dP(j) = 0.0 ; drho_dT_dP(j) = 0.0 + else + call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS(j), rho_sa_ct=drho_dS_dT(j), & + rho_ct_ct=drho_dT_dT(j), rho_sa_p=drho_dS_dP(j), rho_ct_p=drho_dT_dP(j)) + endif enddo end subroutine calculate_density_second_derivs_array_teos10 @@ -280,10 +338,13 @@ subroutine calculate_compress_teos10(T, S, pressure, rho, drho_dp, start, npts) zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity 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 - if(S(j).lt.-1.0e-10) cycle !Can we assume safely that this is a missing value? - rho(j) = gsw_rho(zs,zt,zp) - call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) - enddo + if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? + rho(j) = 1000.0 ; drho_dp(j) = 0.0 + else + rho(j) = gsw_rho(zs,zt,zp) + call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) + endif + enddo end subroutine calculate_compress_teos10 end module MOM_EOS_TEOS10 diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index ca4284d50e..4489f40a2a 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -11,7 +11,7 @@ module MOM_EOS_UNESCO implicit none ; private -public calculate_compress_UNESCO, calculate_density_UNESCO +public calculate_compress_UNESCO, calculate_density_UNESCO, calculate_spec_vol_UNESCO public calculate_density_derivs_UNESCO public calculate_density_scalar_UNESCO, calculate_density_array_UNESCO @@ -19,12 +19,17 @@ module MOM_EOS_UNESCO module procedure calculate_density_scalar_UNESCO, calculate_density_array_UNESCO end interface calculate_density_UNESCO +interface calculate_spec_vol_UNESCO + module procedure calculate_spec_vol_scalar_UNESCO, calculate_spec_vol_array_UNESCO +end interface calculate_spec_vol_UNESCO + + ! The following constants are used to calculate rho0. The notation ! is Rab for the contribution to rho0 from T^aS^b. real, parameter :: R00 = 999.842594, R10 = 6.793952e-2, R20 = -9.095290e-3, & R30 = 1.001685e-4, R40 = -1.120083e-6, R50 = 6.536332e-9, R01 = 0.824493, & R11 = -4.0899e-3, R21 = 7.6438e-5, R31 = -8.2467e-7, R41 = 5.3875e-9, & - R032 = -5.72466e-3, R132 = 1.0227e-4, R232 = -1.6546e-6, R02 = 4.8314e-4; + R032 = -5.72466e-3, R132 = 1.0227e-4, R232 = -1.6546e-6, R02 = 4.8314e-4 ! The following constants are used to calculate the secant bulk mod- ! ulus. The notation here is Sab for terms proportional to T^a*S^b, @@ -36,36 +41,20 @@ module MOM_EOS_UNESCO S232 = -4.619924e-4, Sp00 = 3.186519, Sp10 = 2.212276e-2, Sp20 = -2.984642e-4, & Sp30 = 1.956415e-6, Sp01 = 6.704388e-3, Sp11 = -1.847318e-4, Sp21 = 2.059331e-7, & Sp032 = 1.480266e-4, SP000 = 2.102898e-4, SP010 = -1.202016e-5, SP020 = 1.394680e-7, & - SP001 = -2.040237e-6, SP011 = 6.128773e-8, SP021 = 6.207323e-10; + SP001 = -2.040237e-6, SP011 = 6.128773e-8, SP021 = 6.207323e-10 contains !> This subroutine computes the in situ density of sea water (rho in !! units of kg/m^3) from salinity (S in psu), potential temperature -!! (T in deg C), and pressure in Pa. It uses the expression from -!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -!! Coded by R. Hallberg, 7/00 -subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho) -real, intent(in) :: T !< Potential temperature relative to the surface in C. -real, intent(in) :: S !< Salinity in PSU. -real, intent(in) :: pressure !< Pressure in Pa. -real, intent(out) :: rho !< In situ density in kg m-3. - -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * - -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) from salinity (S in psu), potential temperature * -! * (T in deg C), and pressure in Pa. It uses the expression from * -! * Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. * -! * Coded by R. Hallberg, 7/00 * -! *====================================================================* +!! (T in deg C), and pressure in Pa, using the UNESCO (1981) equation of state. +subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho, rho_ref) + real, intent(in) :: T !< Potential temperature relative to the surface in C. + real, intent(in) :: S !< Salinity in PSU. + real, intent(in) :: pressure !< Pressure in Pa. + real, intent(out) :: rho !< In situ density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. real, dimension(1) :: T0, S0, pressure0 real, dimension(1) :: rho0 @@ -74,22 +63,22 @@ subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho) S0(1) = S pressure0(1) = pressure - call calculate_density_array_UNESCO(T0, S0, pressure0, rho0, 1, 1) + call calculate_density_array_UNESCO(T0, S0, pressure0, rho0, 1, 1, rho_ref) rho = rho0(1) end subroutine calculate_density_scalar_UNESCO !> This subroutine computes the in situ density of sea water (rho in !! units of kg/m^3) from salinity (S in psu), potential temperature -!! (T in deg C), and pressure in Pa. -subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in PSU. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: rho !< In situ density in kg m-3. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. +!! (T in deg C), and pressure in Pa, using the UNESCO (1981) equation of state. +subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface in C. + real, dimension(:), intent(in) :: S !< salinity in PSU. + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. ! * This subroutine computes the in situ density of sea water (rho in * ! * units of kg/m^3) from salinity (S in psu), potential temperature * @@ -102,6 +91,81 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts) ! * (in) start - the starting point in the arrays. * ! * (in) npts - the number of values to calculate. * + real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power. + real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power. + real :: p1, p2 ! Pressure (in bars) to the 1st and 2nd power. + real :: rho0 ! Density at 1 bar pressure, in kg m-3. + real :: sig0 ! The anomaly of rho0 from R00, in kg m-3. + real :: ks ! The secant bulk modulus in bar. + integer :: j + + do j=start,start+npts-1 + if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? + rho(j) = 1000.0 + cycle + endif + + p1 = pressure(j)*1.0e-5; p2 = p1*p1 + t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2 + s_local = S(j); s2 = s_local*s_local; s32 = s_local*sqrt(s_local) + +! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). + + sig0 = R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & + s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & + s32*(R032 + R132*t_local + R232*t2) + R02*s2 + rho0 = R00 + sig0 + +! Compute rho(s,theta,p), first calculating the secant bulk modulus. + + ks = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + & + s32*(S032 + S132*t_local + S232*t2) + & + p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & + s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & + p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) + + if (present(rho_ref)) then + rho(j) = ((R00 - rho_ref)*ks + (sig0*ks + p1*rho_ref)) / (ks - p1) + else + rho(j) = rho0*ks / (ks - p1) + endif + enddo +end subroutine calculate_density_array_UNESCO + +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) +!! and pressure in Pa, using the UNESCO (1981) equation of state. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_scalar_UNESCO(T, S, pressure, specvol, spv_ref) + real, intent(in) :: T !< potential temperature relative to the surface + !! in C. + real, intent(in) :: S !< salinity in PSU. + real, intent(in) :: pressure !< pressure in Pa. + real, intent(out) :: specvol !< in situ specific volume in m3 kg-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + + real, dimension(1) :: T0, S0, pressure0, spv0 + + T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + + call calculate_spec_vol_array_UNESCO(T0, S0, pressure0, spv0, 1, 1, spv_ref) + specvol = spv0(1) +end subroutine calculate_spec_vol_scalar_UNESCO + +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) +!! and pressure in Pa, using the UNESCO (1981) equation of state. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_array_UNESCO(T, S, pressure, specvol, start, npts, spv_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface + !! in C. + real, dimension(:), intent(in) :: S !< salinity in PSU. + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: specvol !< in situ specific volume in m3 kg-1. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + real :: t_local, t2, t3, t4, t5; ! Temperature to the 1st - 5th power. real :: s_local, s32, s2; ! Salinity to the 1st, 3/2, & 2nd power. real :: p1, p2; ! Pressure (in bars) to the 1st and 2nd power. @@ -110,15 +174,21 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts) integer :: j do j=start,start+npts-1 - p1 = pressure(j)*1.0e-5; p2 = p1*p1; - t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2; - s_local = S(j); s2 = s_local*s_local; s32 = s_local*sqrt(s_local); + if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? + specvol(j) = 0.001 + if (present(spv_ref)) specvol(j) = 0.001 - spv_ref + cycle + endif + + p1 = pressure(j)*1.0e-5; p2 = p1*p1 + t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2 + s_local = S(j); s2 = s_local*s_local; s32 = s_local*sqrt(s_local) ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2; + s32*(R032 + R132*t_local + R232*t2) + R02*s2 ! Compute rho(s,theta,p), first calculating the secant bulk modulus. @@ -126,11 +196,16 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts) s32*(S032 + S132*t_local + S232*t2) + & p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & - p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)); + p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) - rho(j) = rho0*ks / (ks - p1); + if (present(spv_ref)) then + specvol(j) = (ks*(1.0 - (rho0*spv_ref)) - p1) / (rho0*ks) + else + specvol(j) = (ks - p1) / (rho0*ks) + endif enddo -end subroutine calculate_density_array_UNESCO +end subroutine calculate_spec_vol_array_UNESCO + !> This subroutine calculates the partial derivatives of density !! with potential temperature and salinity. @@ -171,20 +246,25 @@ subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, sta integer :: j do j=start,start+npts-1 - p1 = pressure(j)*1.0e-5; p2 = p1*p1; - t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2; - s_local = S(j); s2 = s_local*s_local; s12 = sqrt(s_local); s32 = s_local*s12; + if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? + drho_dT(j) = 0.0 ; drho_dS(j) = 0.0 + cycle + endif + + p1 = pressure(j)*1.0e-5; p2 = p1*p1 + t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2 + s_local = S(j); s2 = s_local*s_local; s12 = sqrt(s_local); s32 = s_local*s12 ! compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ) rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2; + s32*(R032 + R132*t_local + R232*t2) + R02*s2 drho0_dT = R10 + 2.0*R20*t_local + 3.0*R30*t2 + 4.0*R40*t3 + 5.0*R50*t4 + & s_local*(R11 + 2.0*R21*t_local + 3.0*R31*t2 + 4.0*R41*t3) + & - s32*(R132 + 2.0*R232*t_local); + s32*(R132 + 2.0*R232*t_local) drho0_dS = (R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - 1.5*s12*(R032 + R132*t_local + R232*t2) + 2.0*R02*s_local; + 1.5*s12*(R032 + R132*t_local + R232*t2) + 2.0*R02*s_local ! compute rho(s,theta,p) @@ -192,18 +272,18 @@ subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, sta s32*(S032 + S132*t_local + S232*t2) + & p1*(Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32) + & - p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)); + p2*(SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2)) dks_dT = S10 + 2.0*S20*t_local + 3.0*S30*t2 + 4.0*S40*t3 + & s_local*(S11 + 2.0*S21*t_local + 3.0*S31*t2) + s32*(S132 + 2.0*S232*t_local) + & p1*(Sp10 + 2.0*Sp20*t_local + 3.0*Sp30*t2 + s_local*(Sp11 + 2.0*Sp21*t_local)) + & - p2*(SP010 + 2.0*SP020*t_local + s_local*(SP011 + 2.0*SP021*t_local)); + p2*(SP010 + 2.0*SP020*t_local + s_local*(SP011 + 2.0*SP021*t_local)) dks_dS = (S01 + S11*t_local + S21*t2 + S31*t3) + 1.5*s12*(S032 + S132*t_local + S232*t2) + & p1*(Sp01 + Sp11*t_local + Sp21*t2 + 1.5*Sp032*s12) + & - p2*(SP001 + SP011*t_local + SP021*t2); + p2*(SP001 + SP011*t_local + SP021*t2) - denom = 1.0 / (ks - p1); - drho_dT(j) = denom*(ks*drho0_dT - rho0*p1*denom*dks_dT); - drho_dS(j) = denom*(ks*drho0_dS - rho0*p1*denom*dks_dS); + denom = 1.0 / (ks - p1) + drho_dT(j) = denom*(ks*drho0_dT - rho0*p1*denom*dks_dT) + drho_dS(j) = denom*(ks*drho0_dS - rho0*p1*denom*dks_dS) enddo end subroutine calculate_density_derivs_UNESCO @@ -242,35 +322,40 @@ subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) real :: p1, p2; ! Pressure (in bars) to the 1st and 2nd power. real :: rho0; ! Density at 1 bar pressure, in kg m-3. real :: ks; ! The secant bulk modulus in bar. - real :: ks_0, ks_1, ks_2; + real :: ks_0, ks_1, ks_2 real :: dks_dp; ! The derivative of the secant bulk modulus ! with pressure, nondimensional. integer :: j do j=start,start+npts-1 - p1 = pressure(j)*1.0e-5; p2 = p1*p1; - t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2; - s_local = S(j); s2 = s_local*s_local; s32 = s_local*sqrt(s_local); + if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? + rho(j) = 1000.0 ; drho_dP(j) = 0.0 + cycle + endif + + p1 = pressure(j)*1.0e-5; p2 = p1*p1 + t_local = T(j); t2 = t_local*t_local; t3 = t_local*t2; t4 = t2*t2; t5 = t3*t2 + s_local = S(j); s2 = s_local*s_local; s32 = s_local*sqrt(s_local) ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). rho0 = R00 + R10*t_local + R20*t2 + R30*t3 + R40*t4 + R50*t5 + & s_local*(R01 + R11*t_local + R21*t2 + R31*t3 + R41*t4) + & - s32*(R032 + R132*t_local + R232*t2) + R02*s2; + s32*(R032 + R132*t_local + R232*t2) + R02*s2 ! Compute rho(s,theta,p), first calculating the secant bulk modulus. ks_0 = S00 + S10*t_local + S20*t2 + S30*t3 + S40*t4 + & - s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + s32*(S032 + S132*t_local + S232*t2); + s_local*(S01 + S11*t_local + S21*t2 + S31*t3) + s32*(S032 + S132*t_local + S232*t2) ks_1 = Sp00 + Sp10*t_local + Sp20*t2 + Sp30*t3 + & - s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32; - ks_2 = SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2); + s_local*(Sp01 + Sp11*t_local + Sp21*t2) + Sp032*s32 + ks_2 = SP000 + SP010*t_local + SP020*t2 + s_local*(SP001 + SP011*t_local + SP021*t2) - ks = ks_0 + p1*ks_1 + p2*ks_2; - dks_dp = ks_1 + 2.0*p1*ks_2; + ks = ks_0 + p1*ks_1 + p2*ks_2 + dks_dp = ks_1 + 2.0*p1*ks_2 - rho(j) = rho0*ks / (ks - p1); + rho(j) = rho0*ks / (ks - p1) ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. - drho_dp(j) = 1.0e-5 * (rho(j) / (ks - p1)) * (1.0 - dks_dp*p1/ks); + drho_dp(j) = 1.0e-5 * (rho(j) / (ks - p1)) * (1.0 - dks_dp*p1/ks) enddo end subroutine calculate_compress_UNESCO diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 4fca115630..ad1908adb5 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -14,7 +14,7 @@ module MOM_EOS_Wright #include -public calculate_compress_wright, calculate_density_wright +public calculate_compress_wright, calculate_density_wright, calculate_spec_vol_wright public calculate_density_derivs_wright, calculate_specvol_derivs_wright public calculate_density_second_derivs_wright public int_density_dz_wright, int_spec_vol_dp_wright @@ -23,6 +23,10 @@ module MOM_EOS_Wright module procedure calculate_density_scalar_wright, calculate_density_array_wright end interface calculate_density_wright +interface calculate_spec_vol_wright + module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright +end interface calculate_spec_vol_wright + interface calculate_density_derivs_wright module procedure calculate_density_derivs_scalar_wright, calculate_density_derivs_array_wright end interface @@ -43,10 +47,10 @@ module MOM_EOS_Wright ! Following are the values for the reduced range formula. -real, parameter :: a0 = 7.057924e-4, a1 = 3.480336e-7, a2 = -1.112733e-7 -real, parameter :: b0 = 5.790749e8, b1 = 3.516535e6, b2 = -4.002714e4 +real, parameter :: a0 = 7.057924e-4, a1 = 3.480336e-7, a2 = -1.112733e-7 ! a0/a1 ~= 2028 ; a0/a2 ~= -6343 +real, parameter :: b0 = 5.790749e8, b1 = 3.516535e6, b2 = -4.002714e4 ! b0/b1 ~= 165 ; b0/b4 ~= 974 real, parameter :: b3 = 2.084372e2, b4 = 5.944068e5, b5 = -9.643486e3 -real, parameter :: c0 = 1.704853e5, c1 = 7.904722e2, c2 = -7.984422 +real, parameter :: c0 = 1.704853e5, c1 = 7.904722e2, c2 = -7.984422 ! c0/c1 ~= 216 ; c0/c4 ~= -740 real, parameter :: c3 = 5.140652e-2, c4 = -2.302158e2, c5 = -3.079464 contains @@ -55,19 +59,12 @@ module MOM_EOS_Wright !! units of kg/m^3) from salinity (S in psu), potential temperature !! (T in deg C), and pressure in Pa. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -!! Coded by R. Hallberg, 7/00 -subroutine calculate_density_scalar_wright(T, S, pressure, rho) -real, intent(in) :: T !< Potential temperature relative to the surface in C. -real, intent(in) :: S !< Salinity in PSU. -real, intent(in) :: pressure !< Pressure in Pa. -real, intent(out) :: rho !< In situ density in kg m-3. - -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * +subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) + real, intent(in) :: T !< Potential temperature relative to the surface in C. + real, intent(in) :: S !< Salinity in PSU. + real, intent(in) :: pressure !< Pressure in Pa. + real, intent(out) :: rho !< In situ density in kg m-3. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. ! *====================================================================* ! * This subroutine computes the in situ density of sea water (rho in * @@ -77,16 +74,13 @@ subroutine calculate_density_scalar_wright(T, S, pressure, rho) ! * Coded by R. Hallberg, 7/00 * ! *====================================================================* - real :: al0, p0, lambda - integer :: j - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: rho0 + real, dimension(1) :: T0, S0, pressure0, rho0 T0(1) = T S0(1) = S pressure0(1) = pressure - call calculate_density_array_wright(T0, S0, pressure0, rho0, 1, 1) + call calculate_density_array_wright(T0, S0, pressure0, rho0, 1, 1, rho_ref) rho = rho0(1) end subroutine calculate_density_scalar_wright @@ -95,30 +89,75 @@ end subroutine calculate_density_scalar_wright !! units of kg/m^3) from salinity (S in psu), potential temperature !! (T in deg C), and pressure in Pa. It uses the expression from !! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. -!! Coded by R. Hallberg, 7/00 -subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts) - real, intent(in), dimension(:) :: T !< potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< salinity in PSU. - real, intent(in), dimension(:) :: pressure !< pressure in Pa. - real, intent(out), dimension(:) :: rho !< in situ density in kg m-3. - integer, intent(in) :: start !< the starting point in the arrays. - integer, intent(in) :: npts !< the number of values to calculate. +subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface in C. + real, dimension(:), intent(in) :: S !< salinity in PSU. + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. + + ! Original coded by R. Hallberg, 7/00, anomaly coded in 3/18. + real :: al0, p0, lambda + real :: al_TS, p_TSp, lam_TS, pa_000 + integer :: j -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * + if (present(rho_ref)) pa_000 = (b0*(1.0 - a0*rho_ref) - rho_ref*c0) + if (present(rho_ref)) then ; do j=start,start+npts-1 + al_TS = a1*T(j) +a2*S(j) + al0 = a0 + al_TS + p_TSp = pressure(j) + (b4*S(j) + T(j) * (b1 + (T(j)*(b2 + b3*T(j)) + b5*S(j)))) + lam_TS = c4*S(j) + T(j) * (c1 + (T(j)*(c2 + c3*T(j)) + c5*S(j))) + + ! The following two expressions are mathematically equivalent. + ! rho(j) = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + rho(j) = (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + enddo ; else ; do j=start,start+npts-1 + al0 = (a0 + a1*T(j)) +a2*S(j) + p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*(b2 + b3*T(j)) + b5*S(j)) + lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*(c2 + c3*T(j)) + c5*S(j)) + rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + enddo ; endif + +end subroutine calculate_density_array_wright + +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) +!! and pressure in Pa. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) + real, intent(in) :: T !< potential temperature relative to the surface in C. + real, intent(in) :: S !< salinity in PSU. + real, intent(in) :: pressure !< pressure in Pa. + real, intent(out) :: specvol !< in situ specific volume in m3 kg-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + + real, dimension(1) :: T0, S0, pressure0, spv0 + + T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + + call calculate_spec_vol_array_wright(T0, S0, pressure0, spv0, 1, 1, spv_ref) + specvol = spv0(1) +end subroutine calculate_spec_vol_scalar_wright + +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) +!! and pressure in Pa. It uses the expression from +!! Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, spv_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface + !! in C. + real, dimension(:), intent(in) :: S !< salinity in PSU. + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: specvol !< in situ specific volume in m3 kg-1. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. -! *====================================================================* -! * This subroutine computes the in situ density of sea water (rho in * -! * units of kg/m^3) from salinity (S in psu), potential temperature * -! * (T in deg C), and pressure in Pa. It uses the expression from * -! * Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. * -! * Coded by R. Hallberg, 7/00 * -! *====================================================================* real :: al0, p0, lambda integer :: j @@ -127,9 +166,13 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts) p0 = (b0 + b4*S(j)) + T(j) * (b1 + T(j)*((b2 + b3*T(j))) + b5*S(j)) lambda = (c0 +c4*S(j)) + T(j) * (c1 + T(j)*((c2 + c3*T(j))) + c5*S(j)) - rho(j) = (pressure(j) + p0) / (lambda + al0*(pressure(j) + p0)) + if (present(spv_ref)) then + specvol(j) = (lambda + (al0 - spv_ref)*(pressure(j) + p0)) / (pressure(j) + p0) + else + specvol(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + endif enddo -end subroutine calculate_density_array_wright +end subroutine calculate_spec_vol_array_wright !> For a given thermodynamic state, return the thermal/haline expansion coefficients subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_dS, start, npts) @@ -364,7 +407,8 @@ end subroutine calculate_compress_wright !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, & - dpa, intz_dpa, intx_dpa, inty_dpa) + dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HII, HIO real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -397,42 +441,32 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, optional, intent(out) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the !! layer divided by the y grid spacing, in Pa. - -! This subroutine calculates analytical and nearly-analytical integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. -! -! Arguments: T - potential temperature relative to the surface in C. -! (in) S - salinity in PSU. -! (in) z_t - height at the top of the layer in m. -! (in) z_b - height at the top of the layer in m. -! (in) rho_ref - A mean density, in kg m-3, that is subtracted out to reduce -! the magnitude of each of the integrals. -! (The pressure is calucated as p~=-z*rho_0*G_e.) -! (in) rho_0 - A density, in kg m-3, that is used to calculate the pressure -! (as p~=-z*rho_0*G_e) used in the equation of state. -! (in) G_e - The Earth's gravitational acceleration, in m s-2. -! (in) G - The ocean's grid structure. -! (out) dpa - The change in the pressure anomaly across the layer, -! in Pa. -! (out,opt) intz_dpa - The integral through the thickness of the layer of the -! pressure anomaly relative to the anomaly at the top of -! the layer, in Pa m. -! (out,opt) intx_dpa - The integral in x of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the x grid spacing, in Pa. -! (out,opt) inty_dpa - The integral in y of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the y grid spacing, in Pa. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry in m + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change with the + !! same units as z_t + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed) :: al0_2d, p0_2d, lambda_2d real :: al0, p0, lambda - real :: eps, eps2, rho_anom, rem - real :: w_left, w_right, intz(5) + real :: rho_anom ! The density anomaly from rho_ref, in kg m-3. + real :: eps, eps2, rem + real :: GxRho, I_Rho + real :: p_ave, I_al0, I_Lzz + real :: dz ! The layer thickness, in m. + real :: hWght ! A pressure-thickness below topography, in m. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in m. + real :: iDenom ! The inverse of the denominator in the wieghts, in m-2. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. + real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: intz(5) ! The integrals of density with height at the + ! 5 sub-column locations, in m2 s-2. + logical :: do_massWeight ! Indicates whether to do mass weighting. real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants. real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. - real :: GxRho, I_Rho - real :: dz, p_ave, I_al0, I_Lzz integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, ioff, joff, m ioff = HIO%idg_offset - HII%idg_offset @@ -448,6 +482,15 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, GxRho = G_e * rho_0 I_Rho = 1.0 / rho_0 + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if useMassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 al0_2d(i,j) = (a0 + a1*T(i,j)) + a2*S(i,j) p0_2d(i,j) = (b0 + b4*S(i,j)) + T(i,j) * (b1 + T(i,j)*((b2 + b3*T(i,j))) + b5*S(i,j)) @@ -473,16 +516,35 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) do m=2,4 - w_left = 0.25*real(m-1) ; w_right = 1.0-w_left - al0 = w_left*al0_2d(i,j) + w_right*al0_2d(i+1,j) - p0 = w_left*p0_2d(i,j) + w_right*p0_2d(i+1,j) - lambda = w_left*lambda_2d(i,j) + w_right*lambda_2d(i+1,j) + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i+1,j) - z_b(i+1,j)) - p_ave = -0.5*GxRho*(w_left*(z_t(i,j)+z_b(i,j)) + & - w_right*(z_t(i+1,j)+z_b(i+1,j))) + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + p_ave = -0.5*GxRho*(wt_L*(z_t(i,j)+z_b(i,j)) + & + wt_R*(z_t(i+1,j)+z_b(i+1,j))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -498,16 +560,35 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HII, HIO, enddo ; enddo ; endif if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + if (hWght > 0.) then + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i-ioff,j+1-joff) do m=2,4 - w_left = 0.25*real(m-1) ; w_right = 1.0-w_left - al0 = w_left*al0_2d(i,j) + w_right*al0_2d(i,j+1) - p0 = w_left*p0_2d(i,j) + w_right*p0_2d(i,j+1) - lambda = w_left*lambda_2d(i,j) + w_right*lambda_2d(i,j+1) + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR - dz = w_left*(z_t(i,j) - z_b(i,j)) + w_right*(z_t(i,j+1) - z_b(i,j+1)) - p_ave = -0.5*GxRho*(w_left*(z_t(i,j)+z_b(i,j)) + & - w_right*(z_t(i,j+1)+z_b(i,j+1))) + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i,j+1) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i,j+1) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i,j+1) + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + p_ave = -0.5*GxRho*(wt_L*(z_t(i,j)+z_b(i,j)) + & + wt_R*(z_t(i,j+1)+z_b(i,j+1))) I_al0 = 1.0 / al0 I_Lzz = 1.0 / (p0 + (lambda * I_al0) + p_ave) @@ -529,8 +610,9 @@ end subroutine int_density_dz_wright !! model. There are essentially no free assumptions, apart from the use of !! Bode's rule to do the horizontal integrals, and from a truncation in the !! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. -subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, & - intp_dza, intx_dza, inty_dza, halo_size) +subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & + intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -541,9 +623,9 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, & intent(in) :: p_t !< Pressure at the top of the layer in Pa. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: p_b !< Pressure at the top of the layer in Pa. - real, intent(in) :: alpha_ref !< A mean specific volume that is subtracted out + real, intent(in) :: spv_ref !< A mean specific volume that is subtracted out !! to reduce the magnitude of each of the integrals, m3 kg-1.The calculation is - !! mathematically identical with different values of alpha_ref, but this reduces the + !! mathematically identical with different values of spv_ref, but this reduces the !! effects of roundoff. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(out) :: dza !< The change in the geopotential anomaly across @@ -564,6 +646,12 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, & !! in m2 s-2. integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate !! dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry in Pa + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t (Pa?) + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -571,35 +659,23 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, & ! model. There are essentially no free assumptions, apart from the use of ! Bode's rule to do the horizontal integrals, and from a truncation in the ! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. -! -! Arguments: T - potential temperature relative to the surface in C. -! (in) S - salinity in PSU. -! (in) p_t - pressure at the top of the layer in Pa. -! (in) p_b - pressure at the top of the layer in Pa. -! (in) alpha_ref - A mean specific volume that is subtracted out to reduce -! the magnitude of each of the integrals, m3 kg-1. -! The calculation is mathematically identical with -! different values of alpha_ref, but this reduces the -! effects of roundoff. -! (in) HI - The ocean's horizontal index structure. -! (out) dza - The change in the geopotential anomaly across the layer, -! in m2 s-2. -! (out,opt) intp_dza - The integral in pressure through the layer of the -! geopotential anomaly relative to the anomaly at the -! bottom of the layer, in Pa m2 s-2. -! (out,opt) intx_dza - The integral in x of the difference between the -! geopotential anomaly at the top and bottom of the layer -! divided by the x grid spacing, in m2 s-2. -! (out,opt) inty_dza - The integral in y of the difference between the -! geopotential anomaly at the top and bottom of the layer -! divided by the y grid spacing, in m2 s-2. -! (in,opt) halo_size - The width of halo points on which to calculate dza. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed) :: al0_2d, p0_2d, lambda_2d real :: al0, p0, lambda - real :: alpha_anom, dp, p_ave + real :: p_ave real :: rem, eps, eps2 - real :: w_left, w_right, intp(5) + real :: alpha_anom ! The depth averaged specific density anomaly in m3 kg-1. + real :: dp ! The pressure change through a layer, in Pa. + real :: hWght ! A pressure-thickness below topography, in Pa. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in Pa. + real :: iDenom ! The inverse of the denominator in the wieghts, in Pa-2. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. + real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations, in m2 s-2. + logical :: do_massWeight ! Indicates whether to do mass weighting. real, parameter :: C1_3 = 1.0/3.0, C1_7 = 1.0/7.0 ! Rational constants. real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo @@ -610,52 +686,66 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, & if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - if (present(intp_dza)) then - do j=jsh,jeh ; do i=ish,ieh - al0_2d(i,j) = (a0 + a1*T(i,j)) + a2*S(i,j) - p0_2d(i,j) = (b0 + b4*S(i,j)) + T(i,j) * (b1 + T(i,j)*((b2 + b3*T(i,j))) + b5*S(i,j)) - lambda_2d(i,j) = (c0 +c4*S(i,j)) + T(i,j) * (c1 + T(i,j)*((c2 + c3*T(i,j))) + c5*S(i,j)) + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. +! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "bathyP must be present if useMassWghtInterp is present and true.") +! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif - al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) - dp = p_b(i,j) - p_t(i,j) - p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + do j=jsh,jeh ; do i=ish,ieh + al0_2d(i,j) = (a0 + a1*T(i,j)) + a2*S(i,j) + p0_2d(i,j) = (b0 + b4*S(i,j)) + T(i,j) * (b1 + T(i,j)*((b2 + b3*T(i,j))) + b5*S(i,j)) + lambda_2d(i,j) = (c0 +c4*S(i,j)) + T(i,j) * (c1 + T(i,j)*((c2 + c3*T(i,j))) + c5*S(i,j)) - eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - alpha_anom = al0 + lambda / (p0 + p_ave) - alpha_ref - rem = lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) - dza(i,j) = alpha_anom*dp + 2.0*eps*rem + al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) + dp = p_b(i,j) - p_t(i,j) + p_ave = 0.5*(p_t(i,j)+p_b(i,j)) + + eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps + alpha_anom = al0 + lambda / (p0 + p_ave) - spv_ref + rem = lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) + dza(i,j) = alpha_anom*dp + 2.0*eps*rem + if (present(intp_dza)) & intp_dza(i,j) = 0.5*alpha_anom*dp**2 - dp*(1.0-eps)*rem - enddo ; enddo - else - do j=jsh,jeh ; do i=ish,ieh - al0_2d(i,j) = (a0 + a1*T(i,j)) + a2*S(i,j) - p0_2d(i,j) = (b0 + b4*S(i,j)) + T(i,j) * (b1 + T(i,j)*((b2 + b3*T(i,j))) + b5*S(i,j)) - lambda_2d(i,j) = (c0 +c4*S(i,j)) + T(i,j) * (c1 + T(i,j)*((c2 + c3*T(i,j))) + c5*S(i,j)) - - al0 = al0_2d(i,j) ; p0 = p0_2d(i,j) ; lambda = lambda_2d(i,j) - dp = p_b(i,j) - p_t(i,j) - p_ave = 0.5*(p_t(i,j)+p_b(i,j)) - - eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - alpha_anom = al0 + lambda / (p0 + p_ave) - alpha_ref - rem = lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) - dza(i,j) = alpha_anom*dp + 2.0*eps*rem - enddo ; enddo - endif + enddo ; enddo if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - al0 = w_left*al0_2d(i,j) + w_right*al0_2d(i+1,j) - p0 = w_left*p0_2d(i,j) + w_right*p0_2d(i+1,j) - lambda = w_left*lambda_2d(i,j) + w_right*lambda_2d(i+1,j) + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness wekghted. + al0 = wtT_L*al0_2d(i,j) + wtT_R*al0_2d(i+1,j) + p0 = wtT_L*p0_2d(i,j) + wtT_R*p0_2d(i+1,j) + lambda = wtT_L*lambda_2d(i,j) + wtT_R*lambda_2d(i+1,j) - dp = w_left*(p_b(i,j) - p_t(i,j)) + w_right*(p_b(i+1,j) - p_t(i+1,j)) - p_ave = 0.5*(w_left*(p_t(i,j)+p_b(i,j)) + w_right*(p_t(i+1,j)+p_b(i+1,j))) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i+1,j)+p_b(i+1,j))) eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - intp(m) = (al0 + lambda / (p0 + p_ave) - alpha_ref)*dp + 2.0*eps* & + intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) enddo ! Use Bode's rule to integrate the values. @@ -664,18 +754,39 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, alpha_ref, HI, dza, & enddo ; enddo ; endif if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + if (hWght > 0.) then + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + else + hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + endif + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) do m=2,4 - w_left = 0.25*real(5-m) ; w_right = 1.0-w_left - al0 = w_left*al0_2d(i,j) + w_right*al0_2d(i,j+1) - p0 = w_left*p0_2d(i,j) + w_right*p0_2d(i,j+1) - lambda = w_left*lambda_2d(i,j) + w_right*lambda_2d(i,j+1) + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness wekghted. + al0 = wt_L*al0_2d(i,j) + wt_R*al0_2d(i,j+1) + p0 = wt_L*p0_2d(i,j) + wt_R*p0_2d(i,j+1) + lambda = wt_L*lambda_2d(i,j) + wt_R*lambda_2d(i,j+1) - dp = w_left*(p_b(i,j) - p_t(i,j)) + w_right*(p_b(i,j+1) - p_t(i,j+1)) - p_ave = 0.5*(w_left*(p_t(i,j)+p_b(i,j)) + w_right*(p_t(i,j+1)+p_b(i,j+1))) + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + p_ave = 0.5*(wt_L*(p_t(i,j)+p_b(i,j)) + wt_R*(p_t(i,j+1)+p_b(i,j+1))) eps = 0.5 * dp / (p0 + p_ave) ; eps2 = eps*eps - intp(m) = (al0 + lambda / (p0 + p_ave) - alpha_ref)*dp + 2.0*eps* & + intp(m) = (al0 + lambda / (p0 + p_ave) - spv_ref)*dp + 2.0*eps* & lambda * eps2 * (C1_3 + eps2*(0.2 + eps2*(C1_7 + C1_9*eps2))) enddo ! Use Bode's rule to integrate the values. diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index fb4ead9609..5ad35134ba 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -13,7 +13,7 @@ module MOM_EOS_linear #include -public calculate_compress_linear, calculate_density_linear +public calculate_compress_linear, calculate_density_linear, calculate_spec_vol_linear public calculate_density_derivs_linear, calculate_density_derivs_scalar_linear public calculate_specvol_derivs_linear public calculate_density_scalar_linear, calculate_density_array_linear @@ -24,6 +24,10 @@ module MOM_EOS_linear module procedure calculate_density_scalar_linear, calculate_density_array_linear end interface calculate_density_linear +interface calculate_spec_vol_linear + module procedure calculate_spec_vol_scalar_linear, calculate_spec_vol_array_linear +end interface calculate_spec_vol_linear + interface calculate_density_derivs_linear module procedure calculate_density_derivs_scalar_linear, calculate_density_derivs_array_linear end interface calculate_density_derivs_linear @@ -38,16 +42,17 @@ module MOM_EOS_linear !! linear equation of state (in kg/m^3) from salinity (sal in psu), !! potential temperature (T in deg C), and pressure in Pa. subroutine calculate_density_scalar_linear(T, S, pressure, rho, & - Rho_T0_S0, dRho_dT, dRho_dS) - real, intent(in) :: T !< Potential temperature relative to the surface in C. - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pressure !< Pressure in Pa. - real, intent(out) :: rho !< In situ density in kg m-3. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature and salinity, - !! in kg m-3 C-1 and kg m-3 psu-1. - real, intent(in) :: dRho_dS !< The derivatives of density with temperature and salinity, - !! in kg m-3 C-1 and kg m-3 psu-1. + Rho_T0_S0, dRho_dT, dRho_dS, rho_ref) + real, intent(in) :: T !< Potential temperature relative to the surface in C. + real, intent(in) :: S !< Salinity in PSU. + real, intent(in) :: pressure !< Pressure in Pa. + real, intent(out) :: rho !< In situ density in kg m-3. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. + real, intent(in) :: dRho_dT !< The derivatives of density with temperature + !! in kg m-3 C-1. + real, intent(in) :: dRho_dS !< The derivatives of density with salinity + !! in kg m-3 psu-1. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. ! * This subroutine computes the density of sea water with a trivial * ! * linear equation of state (in kg/m^3) from salinity (sal in psu), * @@ -63,7 +68,11 @@ subroutine calculate_density_scalar_linear(T, S, pressure, rho, & ! * (in) dRho_dT - The derivatives of density with temperature * ! * (in) dRho_dS - and salinity, in kg m-3 C-1 and kg m-3 psu-1. * - rho = Rho_T0_S0 + dRho_dT*T + dRho_dS*S + if (present(rho_ref)) then + rho = (Rho_T0_S0 - rho_ref) + (dRho_dT*T + dRho_dS*S) + else + rho = Rho_T0_S0 + dRho_dT*T + dRho_dS*S + endif end subroutine calculate_density_scalar_linear @@ -71,40 +80,88 @@ end subroutine calculate_density_scalar_linear !! linear equation of state (in kg/m^3) from salinity (sal in psu), !! potential temperature (T in deg C), and pressure in Pa. subroutine calculate_density_array_linear(T, S, pressure, rho, start, npts, & - Rho_T0_S0, dRho_dT, dRho_dS) - real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface - !! in C. - real, intent(in), dimension(:) :: S !< Salinity in PSU. - real, intent(in), dimension(:) :: pressure !< Pressure in Pa. - real, intent(out), dimension(:) :: rho !< In situ density in kg m-3. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. - real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with - !! temperature and salinity, in kg m-3 C-1 - !! and kg m-3 psu-1. + Rho_T0_S0, dRho_dT, dRho_dS, rho_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface in C. + real, dimension(:), intent(in) :: S !< salinity in PSU. + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: rho !< in situ density in kg m-3. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. + real, intent(in) :: dRho_dT !< The derivatives of density with temperature + !! in kg m-3 C-1. + real, intent(in) :: dRho_dS !< The derivatives of density with salinity + !! in kg m-3 psu-1. + real, optional, intent(in) :: rho_ref !< A reference density in kg m-3. -! * This subroutine computes the density of sea water with a trivial * -! * linear equation of state (in kg/m^3) from salinity (sal in psu), * -! * potential temperature (T in deg C), and pressure in Pa. * -! * * -! * Arguments: T - potential temperature relative to the surface in C. * -! * (in) S - salinity in PSU. * -! * (in) pressure - pressure in Pa. * -! * (out) rho - in situ density in kg m-3. * -! * (in) start - the starting point in the arrays. * -! * (in) npts - the number of values to calculate. * -! * (in) Rho_T0_S0 - The density at T=0, S=0, in kg m-3. * -! * (in) dRho_dT - The derivatives of density with temperature * -! * (in) dRho_dS - and salinity, in kg m-3 C-1 and kg m-3 psu-1. * - real :: al0, p0, lambda integer :: j - do j=start,start+npts-1 + if (present(rho_ref)) then ; do j=start,start+npts-1 + rho(j) = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(j) + dRho_dS*S(j)) + enddo ; else ; do j=start,start+npts-1 rho(j) = Rho_T0_S0 + dRho_dT*T(j) + dRho_dS*S(j) - enddo + enddo ; endif + end subroutine calculate_density_array_linear +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) +!! and pressure in Pa, using a trivial linear equation of state for density. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_scalar_linear(T, S, pressure, specvol, & + Rho_T0_S0, dRho_dT, dRho_dS, spv_ref) + real, intent(in) :: T !< potential temperature relative to the surface + !! in C. + real, intent(in) :: S !< salinity in PSU. + real, intent(in) :: pressure !< pressure in Pa. + real, intent(out) :: specvol !< in situ specific volume in m3 kg-1. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. + real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with + !! temperature and salinity, in kg m-3 C-1 + !! and kg m-3 psu-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + + integer :: j + + if (present(spv_ref)) then + specvol = ((1.0 - Rho_T0_S0*spv_ref) + spv_ref*(dRho_dT*T + dRho_dS*S)) / & + ( Rho_T0_S0 + (dRho_dT*T + dRho_dS*S)) + else + specvol = 1.0 / ( Rho_T0_S0 + (dRho_dT*T + dRho_dS*S)) + endif + +end subroutine calculate_spec_vol_scalar_linear + +!> This subroutine computes the in situ specific volume of sea water (specvol in +!! units of m^3/kg) from salinity (S in psu), potential temperature (T in deg C) +!! and pressure in Pa, using a trivial linear equation of state for density. +!! If spv_ref is present, specvol is an anomaly from spv_ref. +subroutine calculate_spec_vol_array_linear(T, S, pressure, specvol, start, npts, & + Rho_T0_S0, dRho_dT, dRho_dS, spv_ref) + real, dimension(:), intent(in) :: T !< potential temperature relative to the surface + !! in C. + real, dimension(:), intent(in) :: S !< salinity in PSU. + real, dimension(:), intent(in) :: pressure !< pressure in Pa. + real, dimension(:), intent(out) :: specvol !< in situ specific volume in m3 kg-1. + integer, intent(in) :: start !< the starting point in the arrays. + integer, intent(in) :: npts !< the number of values to calculate. + real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0, in kg m-3. + real, intent(in) :: dRho_dT, dRho_dS !< The derivatives of density with + !! temperature and salinity, in kg m-3 C-1 + !! and kg m-3 psu-1. + real, optional, intent(in) :: spv_ref !< A reference specific volume in m3 kg-1. + + integer :: j + + if (present(spv_ref)) then ; do j=start,start+npts-1 + specvol(j) = ((1.0 - Rho_T0_S0*spv_ref) + spv_ref*(dRho_dT*T(j) + dRho_dS*S(j))) / & + ( Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) + enddo ; else ; do j=start,start+npts-1 + specvol(j) = 1.0 / ( Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j))) + enddo ; endif + +end subroutine calculate_spec_vol_array_linear + !> This subroutine calculates the partial derivatives of density * !! with potential temperature and salinity. subroutine calculate_density_derivs_array_linear(T, S, pressure, drho_dT_out, & @@ -305,7 +362,8 @@ end subroutine calculate_compress_linear !! pressure anomalies across layers, which are required for calculating the !! finite-volume form pressure accelerations in a Boussinesq model. subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, HIO, & - Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa) + Rho_T0_S0, dRho_dT, dRho_dS, dpa, intz_dpa, intx_dpa, inty_dpa, & + bathyT, dz_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HII, HIO real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -345,40 +403,28 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, optional, intent(out) :: inty_dpa !< The integral in y of the difference between the !! pressure anomaly at the top and bottom of the !! layer divided by the y grid spacing, in Pa. + real, dimension(HII%isd:HII%ied,HII%jsd:HII%jed), & + optional, intent(in) :: bathyT !< The depth of the bathymetry in m + real, optional, intent(in) :: dz_neglect !< A miniscule thickness change with the + !! same units as z_t + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting to + !! interpolate T/S for top and bottom integrals. -! This subroutine calculates analytical and nearly-analytical integrals of -! pressure anomalies across layers, which are required for calculating the -! finite-volume form pressure accelerations in a Boussinesq model. -! -! Arguments: T - potential temperature relative to the surface in C. -! (in) S - salinity in PSU. -! (in) z_t - height at the top of the layer in m. -! (in) z_b - height at the top of the layer in m. -! (in) rho_ref - A mean density, in kg m-3, that is subtracted out to reduce -! the magnitude of each of the integrals. -! (in) rho_0_pres - A density, in kg m-3, that is used to calculate the -! pressure (as p~=-z*rho_0_pres*G_e) used in the equation of -! state. rho_0_pres is not used here. -! (in) G_e - The Earth's gravitational acceleration, in m s-2. -! (in) G - The ocean's grid structure. -! (in) Rho_T0_S0 - The density at T=0, S=0, in kg m-3. -! (in) dRho_dT - The derivative of density with temperature in kg m-3 C-1. -! (in) dRho_dS - The derivative of density with salinity, in kg m-3 psu-1. -! (out) dpa - The change in the pressure anomaly across the layer, in Pa. -! (out,opt) intz_dpa - The integral through the thickness of the layer of the -! pressure anomaly relative to the anomaly at the top of -! the layer, in Pa m. -! (out,opt) intx_dpa - The integral in x of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the x grid spacing, in Pa. -! (out,opt) inty_dpa - The integral in y of the difference between the -! pressure anomaly at the top and bottom of the layer -! divided by the y grid spacing, in Pa. real :: rho_anom ! The density anomaly from rho_ref, in kg m-3. real :: raL, raR ! rho_anom to the left and right, in kg m-3. real :: dz, dzL, dzR ! Layer thicknesses in m. - real :: C1_6 - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, ioff, joff + real :: hWght ! A pressure-thickness below topography, in m. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in m. + real :: iDenom ! The inverse of the denominator in the wieghts, in m-2. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. + real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: intz(5) ! The integrals of density with height at the + ! 5 sub-column locations, in m2 s-2. + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants. + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, ioff, joff, m ioff = HIO%idg_offset - HII%idg_offset joff = HIO%jdg_offset - HII%jdg_offset @@ -389,7 +435,15 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, Jsq = HIO%JscB + joff ; Jeq = HIO%JecB + joff is = HIO%isc + ioff ; ie = HIO%iec + ioff js = HIO%jsc + joff ; je = HIO%jec + joff - C1_6 = 1.0 / 6.0 + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. + ! if (.not.present(bathyT)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "bathyT must be present if useMassWghtInterp is present and true.") + ! if (.not.present(dz_neglect)) call MOM_error(FATAL, "int_density_dz_generic: "//& + ! "dz_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz = z_t(i,j) - z_b(i,j) @@ -399,19 +453,82 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HII, enddo ; enddo if (present(intx_dpa)) then ; do j=js,je ; do I=Isq,Ieq - dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i+1,j) - z_b(i+1,j) - raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) - raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) - - intx_dpa(i-ioff,j-joff) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i+1,j), -bathyT(i+1,j)-z_t(i,j)) + + if (hWght <= 0.0) then + dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i+1,j) - z_b(i+1,j) + raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) + raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j)) + + intx_dpa(i-ioff,j-joff) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + else + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i+1,j) - z_b(i+1,j)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + + intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + rho_anom = (Rho_T0_S0 - rho_ref) + & + (dRho_dT * (wtT_L*T(i,j) + wtT_R*T(i+1,j)) + & + dRho_dS * (wtT_L*S(i,j) + wtT_R*S(i+1,j))) + intz(m) = G_e*rho_anom*dz + enddo + ! Use Bode's rule to integrate the values. + intx_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + endif enddo ; enddo ; endif if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=is,ie - dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i,j+1) - z_b(i,j+1) - raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) - raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., -bathyT(i,j)-z_t(i,j+1), -bathyT(i,j+1)-z_t(i,j)) + + if (hWght <= 0.0) then + dzL = z_t(i,j) - z_b(i,j) ; dzR = z_t(i,j+1) - z_b(i,j+1) + raL = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j) + dRho_dS*S(i,j)) + raR = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1)) + + inty_dpa(i-ioff,j-joff) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) + else + hL = (z_t(i,j) - z_b(i,j)) + dz_neglect + hR = (z_t(i,j+1) - z_b(i,j+1)) + dz_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + + intz(1) = dpa(i-ioff,j-joff) ; intz(5) = dpa(i+1-ioff,j-joff) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + rho_anom = (Rho_T0_S0 - rho_ref) + & + (dRho_dT * (wtT_L*T(i,j) + wtT_R*T(i,j+1)) + & + dRho_dS * (wtT_L*S(i,j) + wtT_R*S(i,j+1))) + intz(m) = G_e*rho_anom*dz + enddo + ! Use Bode's rule to integrate the values. + inty_dpa(i-ioff,j-joff) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + & + 12.0*intz(3)) + endif - inty_dpa(i-ioff,j-joff) = G_e*C1_6 * (dzL*(2.0*raL + raR) + dzR*(2.0*raR + raL)) enddo ; enddo ; endif end subroutine int_density_dz_linear @@ -420,7 +537,8 @@ end subroutine int_density_dz_linear !! calculating the finite-volume form pressure accelerations in a non-Boussinesq !! model. Specific volume is assumed to vary linearly between adjacent points. subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & - dRho_dT, dRho_dS, dza, intp_dza, intx_dza, inty_dza, halo_size) + dRho_dT, dRho_dS, dza, intp_dza, intx_dza, inty_dza, halo_size, & + bathyP, dP_neglect, useMassWghtInterp) type(hor_index_type), intent(in) :: HI !< The ocean's horizontal index type. real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & intent(in) :: T !< Potential temperature relative to the surface @@ -457,7 +575,13 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & !! geopotential anomaly at the top and bottom of !! the layer divided by the y grid spacing, !! in m2 s-2. - integer, optional, intent(in) :: halo_size + integer, optional, intent(in) :: halo_size !< The width of halo points on which to calculate dza. + real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed), & + optional, intent(in) :: bathyP !< The pressure at the bathymetry in Pa + real, optional, intent(in) :: dP_neglect !< A miniscule pressure change with + !! the same units as p_t (Pa?) + logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting + !! to interpolate T/S for top and bottom integrals. ! This subroutine calculates analytical and nearly-analytical integrals in ! pressure across layers of geopotential anomalies, which are required for @@ -492,15 +616,33 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & real :: alpha_anom ! The specific volume anomaly from 1/rho_ref, in m3 kg-1. real :: aaL, aaR ! rho_anom to the left and right, in kg m-3. real :: dp, dpL, dpR ! Layer pressure thicknesses in Pa. - real :: C1_6 - integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, halo + real :: hWght ! A pressure-thickness below topography, in Pa. + real :: hL, hR ! Pressure-thicknesses of the columns to the left and right, in Pa. + real :: iDenom ! The inverse of the denominator in the wieghts, in Pa-2. + real :: hWt_LL, hWt_LR ! hWt_LA is the weighted influence of A on the left column, nonDim. + real :: hWt_RL, hWt_RR ! hWt_RA is the weighted influence of A on the right column, nonDim. + real :: wt_L, wt_R ! The linear wieghts of the left and right columns, nonDim. + real :: wtT_L, wtT_R ! The weights for tracers from the left and right columns, nonDim. + real :: intp(5) ! The integrals of specific volume with pressure at the + ! 5 sub-column locations, in m2 s-2. + logical :: do_massWeight ! Indicates whether to do mass weighting. + real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants. + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, halo Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) ish = HI%isc-halo ; ieh = HI%iec+halo ; jsh = HI%jsc-halo ; jeh = HI%jec+halo if (present(intx_dza)) then ; ish = MIN(Isq,ish) ; ieh = MAX(Ieq+1,ieh); endif if (present(inty_dza)) then ; jsh = MIN(Jsq,jsh) ; jeh = MAX(Jeq+1,jeh); endif - C1_6 = 1.0 / 6.0 + + do_massWeight = .false. + if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then + do_massWeight = .true. +! if (.not.present(bathyP)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "bathyP must be present if useMassWghtInterp is present and true.") +! if (.not.present(dP_neglect)) call MOM_error(FATAL, "int_spec_vol_dp_generic: "//& +! "dP_neglect must be present if useMassWghtInterp is present and true.") + endif ; endif do j=jsh,jeh ; do i=ish,ieh dp = p_b(i,j) - p_t(i,j) @@ -512,23 +654,93 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & enddo ; enddo if (present(intx_dza)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i+1,j) - p_t(i+1,j) - dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) - aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - dRho_TS = dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j) - aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - - intx_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL)) + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i+1,j), bathyP(i+1,j)-p_t(i,j)) + + if (hWght <= 0.0) then + dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i+1,j) - p_t(i+1,j) + dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) + aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + dRho_TS = dRho_dT*T(i+1,j) + dRho_dS*S(i+1,j) + aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + + intx_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL)) + else + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i+1,j) - p_t(i+1,j)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness wekghted. + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + + dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i+1,j)) + & + dRho_dS*(wtT_L*S(i,j) + wtT_R*S(i+1,j)) + ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + intp(m) = alpha_anom*dp + enddo + ! Use Bode's rule to integrate the interface height anomaly values in y. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + endif enddo ; enddo ; endif if (present(inty_dza)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i,j+1) - p_t(i,j+1) - dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) - aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - dRho_TS = dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1) - aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) - - inty_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL)) + ! hWght is the distance measure by which the cell is violation of + ! hydrostatic consistency. For large hWght we bias the interpolation of + ! T & S along the top and bottom integrals, akin to thickness weighting. + hWght = 0.0 + if (do_massWeight) & + hWght = max(0., bathyP(i,j)-p_t(i,j+1), bathyP(i,j+1)-p_t(i,j)) + + if (hWght <= 0.0) then + dpL = p_b(i,j) - p_t(i,j) ; dpR = p_b(i,j+1) - p_t(i,j+1) + dRho_TS = dRho_dT*T(i,j) + dRho_dS*S(i,j) + aaL = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + dRho_TS = dRho_dT*T(i,j+1) + dRho_dS*S(i,j+1) + aaR = ((1.0 - Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + + inty_dza(i,j) = C1_6 * (2.0*(dpL*aaL + dpR*aaR) + (dpL*aaR + dpR*aaL)) + else + hL = (p_b(i,j) - p_t(i,j)) + dP_neglect + hR = (p_b(i,j+1) - p_t(i,j+1)) + dP_neglect + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1.0 / ( hWght*(hR + hL) + hL*hR ) + hWt_LL = (hWght*hL + hR*hL) * iDenom ; hWt_LR = (hWght*hR) * iDenom + hWt_RR = (hWght*hR + hR*hL) * iDenom ; hWt_RL = (hWght*hL) * iDenom + + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + wt_L = 0.25*real(5-m) ; wt_R = 1.0-wt_L + wtT_L = wt_L*hWt_LL + wt_R*hWt_RL ; wtT_R = wt_L*hWt_LR + wt_R*hWt_RR + + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness wekghted. + dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + + dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i,j+1)) + & + dRho_dS*(wtT_L*S(i,j) + wtT_R*S(i,j+1)) + ! alpha_anom = 1.0/(Rho_T0_S0 + dRho_TS)) - alpha_ref + alpha_anom = ((1.0-Rho_T0_S0*alpha_ref) - dRho_TS*alpha_ref) / (Rho_T0_S0 + dRho_TS) + intp(m) = alpha_anom*dp + enddo + ! Use Bode's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) + endif enddo ; enddo ; endif end subroutine int_spec_vol_dp_linear diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index aef6b60ecb..ddc0e215da 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -205,7 +205,7 @@ subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) zs = S(j) zp = pres(j)* Pa2db !Convert pressure from Pascal to decibar - if(S(j).lt.-1.0e-10) cycle !Can we assume safely that this is a missing value? + 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 diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index bcf106b881..da90ef1ad7 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -13,6 +13,7 @@ module MOM_checksums public :: hchksum, Bchksum, uchksum, vchksum, qchksum, is_NaN, chksum public :: hchksum_pair, uvchksum, Bchksum_pair +public :: chksum_general public :: MOM_checksums_init interface hchksum_pair @@ -60,6 +61,10 @@ module MOM_checksums module procedure is_NaN_0d, is_NaN_1d, is_NaN_2d, is_NaN_3d end interface +interface chksum_general + module procedure chksum_general_1d, chksum_general_2d, chksum_general_3d +end interface + integer, parameter :: default_shift=0 logical :: calculateStatistics=.true. ! If true, report min, max and mean. logical :: writeChksums=.true. ! If true, report the bitcount checksum @@ -183,26 +188,25 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) endif contains - integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale - integer :: bitcount, i, j, bc + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. + integer :: i, j, bc subchk = 0 do j=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,j))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk subroutine subStats(HI, array, mesg) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array - character(len=*), intent(in) :: mesg + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message integer :: i, j, n real :: aMean, aMin, aMax @@ -231,7 +235,8 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%isd:,HI%jsd:), intent(in) :: arrayA, arrayB !< The arrays to be checksummed - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. @@ -257,7 +262,8 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, omit type(hor_index_type), intent(in) :: HI !< A horizontal index type real, dimension(HI%IsdB:,HI%JsdB:, :), intent(in) :: arrayA, arrayB !< The arrays to be checksummed integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. @@ -369,26 +375,27 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale - integer :: bitcount, i, j, bc + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. + integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj; do I=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(I,J))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, n, IsB, JsB real :: aMean, aMin, aMax @@ -421,7 +428,8 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, omit_cor real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: arrayU !< The u-component array to be checksummed real, dimension(HI%isd:,HI%JsdB:), intent(in) :: arrayV !< The v-component array to be checksummed integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for these arrays. @@ -441,7 +449,8 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, omit_cor real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: arrayU !< The u-component array to be checksummed real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: arrayV !< The v-component array to be checksummed integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for these arrays. @@ -461,7 +470,8 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. @@ -553,26 +563,27 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale - integer :: bitcount, i, j, bc + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. + integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do j=HI%jsc+dj,HI%jec+dj; do I=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(I,j))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, n, IsB real :: aMean, aMin, aMax @@ -604,7 +615,8 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. @@ -696,26 +708,27 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale - integer :: bitcount, i, j, bc + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. + integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do J=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,J))) subchk = subchk + bc - enddo; enddo + enddo ; enddo call sum_across_PEs(subchk) subchk=mod(subchk,1000000000) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, n, JsB real :: aMean, aMin, aMax @@ -822,11 +835,11 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale - integer :: bitcount, i, j, k, bc + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. + integer :: i, j, k, bc subchk = 0 do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di bc = bitcount(abs(scale*array(i,j,k))) @@ -837,9 +850,9 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array - character(len=*), intent(in) :: mesg + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message integer :: i, j, k, n real :: aMean, aMin, aMax @@ -870,7 +883,8 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. @@ -962,11 +976,11 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale - integer :: bitcount, i, j, k, bc + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. + integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di @@ -978,10 +992,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, k, n, IsB, JsB real :: aMean, aMin, aMax @@ -1013,7 +1028,8 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal real, dimension(HI%isdB:,HI%Jsd:,:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. @@ -1105,11 +1121,11 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale - integer :: bitcount, i, j, k, bc + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. + integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do I=HI%isc+di,HI%iec+di @@ -1121,10 +1137,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, k, n, IsB real :: aMean, aMin, aMax @@ -1148,6 +1165,79 @@ end subroutine subStats end subroutine chksum_u_3d +!---chksum_general interface routines +!> Return the bitcount of an arbitrarily sized 3d array +integer function chksum_general_3d( array, scale_factor, istart, iend, jstart, jend, kstart, kend ) & + result(subchk) + real, dimension(:,:,:), intent(in) :: array !< Array to be checksummed + real, optional, intent(in) :: scale_factor !< Factor to scale array by before checksum + integer, optional, intent(in) :: istart !< Starting index in the i-direction + integer, optional, intent(in) :: iend !< Ending index in the i-direction + integer, optional, intent(in) :: jstart !< Starting index in the j-direction + integer, optional, intent(in) :: jend !< Ending index in the j-direction + integer, optional, intent(in) :: kstart !< Starting index in the k-direction + integer, optional, intent(in) :: kend !< Ending index in the k-direction + integer :: i, j, k, bc, is, ie, js, je, ks, ke + real :: scale + + ! By default do not scale + scale = 1. + if (present(scale_factor)) scale = scale_factor + + ! Set the loop indices based on full array + is = LBOUND(array,1) ; ie = UBOUND(array,1) + js = LBOUND(array,2) ; je = UBOUND(array,2) + ks = LBOUND(array,3) ; ke = UBOUND(array,3) + + ! Override indices if subdomain requested + if (present(istart)) is = istart ; if (present(iend)) ie = iend + if (present(jstart)) js = jstart ; if (present(jend)) je = jend + if (present(kstart)) ks = kstart ; if (present(kend)) ke = kend + + subchk = 0 + do k=ks,ke ; do j=js,je ; do i=is,ie + bc = bitcount(abs(scale*array(i,j,k))) + subchk = subchk + bc + enddo ; enddo ; enddo + call sum_across_PEs(subchk) + subchk=mod(subchk,1000000000) +end function chksum_general_3d + +!> Return the bitcount of an arbitrarily sized 2d array by promotion to a 3d array +integer function chksum_general_2d( array_2d, scale_factor, istart, iend, jstart, jend ) + real, dimension(:,:), intent(in) :: array_2d !< Array to be checksummed + real, optional, intent(in) :: scale_factor !< Factor to scale array by before checksum + integer, optional, intent(in) :: istart !< Starting index in the i-direction + integer, optional, intent(in) :: iend !< Ending index in the i-direction + integer, optional, intent(in) :: jstart !< Starting index in the j-direction + integer, optional, intent(in) :: jend !< Ending index in the j-direction + integer :: is, ie, js, je + real, dimension(:,:,:), allocatable :: array_3d !< Promotion from 2d to 3d array + + is = LBOUND(array_2d,1) ; ie = UBOUND(array_2d,1) + js = LBOUND(array_2d,2) ; je = UBOUND(array_2d,2) + allocate(array_3d(is:ie, js:je,1)) + array_3d(:,:,1) = array_2d(:,:) + chksum_general_2d = chksum_general_3d( array_3d, scale_factor, istart, iend, jstart, jend ) + deallocate(array_3d) +end function chksum_general_2d + +!> Return the bitcount of an arbitrarily sized 1d array by promotion to a 3d array +integer function chksum_general_1d( array_1d, scale_factor, istart, iend ) + real, dimension(:), intent(in) :: array_1d !< Array to be checksummed + real, optional, intent(in) :: scale_factor !< Factor to scale array by before checksum + integer, optional, intent(in) :: istart !< Starting index in the i-direction + integer, optional, intent(in) :: iend !< Ending index in the i-direction + integer :: is, ie + real, dimension(:,:,:), allocatable :: array_3d !< Promotion from 2d to 3d array + + is = LBOUND(array_1d,1) ; ie = UBOUND(array_1d,1) + allocate(array_3d(is:ie, 1,1)) + array_3d(:,1,1) = array_1d(:) + chksum_general_1d = chksum_general_3d( array_3d, scale_factor, istart, iend ) + deallocate(array_3d) +end function chksum_general_1d + ! ===================================================================== !> chksum_v_3d performs checksums on a 3d array staggered at C-grid v points. @@ -1156,7 +1246,8 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) - logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full symmetric computational domain. + logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full + !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: scale !< A scaling factor for this array. @@ -1248,11 +1339,11 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale - integer :: bitcount, i, j, k, bc + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. + integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. do k=LBOUND(array,3),UBOUND(array,3) ; do J=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di @@ -1264,10 +1355,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, k, n, JsB real :: aMean, aMin, aMax @@ -1307,7 +1399,6 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) !! and list the root_PE value (default true) integer :: is, ie, i, bc, sum1, sum_bc - integer :: bitcount real :: sum real, allocatable :: sum_here(:) logical :: compare @@ -1360,10 +1451,9 @@ end subroutine chksum1d !> chksum2d does a checksum of all data in a 2-d array. subroutine chksum2d(array, mesg) - real, dimension(:,:) :: array - character(len=*) :: mesg + real, dimension(:,:) :: array !< The array to be checksummed + character(len=*) :: mesg !< An identifying message - integer :: bitcount integer :: xs,xe,ys,ye,i,j,sum1,bc real :: sum @@ -1389,10 +1479,9 @@ end subroutine chksum2d !> chksum3d does a checksum of all data in a 2-d array. subroutine chksum3d(array, mesg) - real, dimension(:,:,:) :: array - character(len=*) :: mesg + real, dimension(:,:,:) :: array !< The array to be checksummed + character(len=*) :: mesg !< An identifying message - integer :: bitcount integer :: xs,xe,ys,ye,zs,ze,i,j,k, bc,sum1 real :: sum @@ -1439,8 +1528,9 @@ end function is_NaN_0d !> This function returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_1d(x, skip_mpp) real, dimension(:), intent(in) :: x !< The array to be checked for NaNs. + logical, optional, intent(in) :: skip_mpp !< If true, only check this array only + !! on the local PE (default false). logical :: is_NaN_1d - logical, optional :: skip_mpp !< If true, only check this array only on the local PE (default false). integer :: i, n logical :: call_mpp @@ -1499,63 +1589,75 @@ function is_NaN_3d(x) end function is_NaN_3d ! ===================================================================== - +!> Write a message including the checksum of the non-shifted array subroutine chk_sum_msg1(fmsg,bc0,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0 + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array if (is_root_pe()) write(0,'(A,1(A,I10,X),A)') fmsg," c=",bc0,trim(mesg) end subroutine chk_sum_msg1 ! ===================================================================== - +!> Write a message including checksums of non-shifted and diagonally shifted arrays subroutine chk_sum_msg5(fmsg,bc0,bcSW,bcSE,bcNW,bcNE,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0,bcSW,bcSE,bcNW,bcNE + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcSW,bcSE,bcNW,bcNE !< The bitcounts for 4 diagonal array shifts if (is_root_pe()) write(0,'(A,5(A,I10,1X),A)') & fmsg," c=",bc0,"sw=",bcSW,"se=",bcSE,"nw=",bcNW,"ne=",bcNE,trim(mesg) end subroutine chk_sum_msg5 ! ===================================================================== - +!> Write a message including checksums of non-shifted and laterally shifted arrays subroutine chk_sum_msg_NSEW(fmsg,bc0,bcN,bcS,bcE,bcW,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcN, bcS, bcE, bcW + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcN, bcS, bcE, bcW !< The bitcounts including 4 lateral array shifts if (is_root_pe()) write(0,'(A,5(A,I10,1X),A)') & fmsg," c=",bc0,"N=",bcN,"S=",bcS,"E=",bcE,"W=",bcW,trim(mesg) end subroutine chk_sum_msg_NSEW ! ===================================================================== - +!> Write a message including checksums of non-shifted and southward shifted arrays subroutine chk_sum_msg_S(fmsg,bc0,bcS,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcS + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcS !< The bitcount of the south-shifted array if (is_root_pe()) write(0,'(A,2(A,I10,1X),A)') & fmsg," c=",bc0,"S=",bcS,trim(mesg) end subroutine chk_sum_msg_S ! ===================================================================== - +!> Write a message including checksums of non-shifted and westward shifted arrays subroutine chk_sum_msg_W(fmsg,bc0,bcW,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcW + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcW !< The bitcount of the west-shifted array if (is_root_pe()) write(0,'(A,2(A,I10,1X),A)') & fmsg," c=",bc0,"W=",bcW,trim(mesg) end subroutine chk_sum_msg_W ! ===================================================================== - +!> Write a message including checksums of non-shifted and southwestward shifted arrays subroutine chk_sum_msg2(fmsg,bc0,bcSW,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0,bcSW + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcSW !< The bitcount of the southwest-shifted array if (is_root_pe()) write(0,'(A,2(A,I9,1X),A)') & fmsg," c=",bc0,"s/w=",bcSW,trim(mesg) end subroutine chk_sum_msg2 ! ===================================================================== - +!> Write a message including the global mean, maximum and minimum of an array subroutine chk_sum_msg3(fmsg,aMean,aMin,aMax,mesg) - character(len=*), intent(in) :: fmsg, mesg - real, intent(in) :: aMean,aMin,aMax + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + real, intent(in) :: aMean,aMin,aMax !< The mean, minimum and maximum of the array if (is_root_pe()) write(0,'(A,3(A,ES25.16,1X),A)') & fmsg," mean=",aMean,"min=",aMin,"max=",aMax,trim(mesg) end subroutine chk_sum_msg3 @@ -1575,15 +1677,32 @@ subroutine MOM_checksums_init(param_file) end subroutine MOM_checksums_init ! ===================================================================== - +!> A wrapper for MOM_error used in the checksum code subroutine chksum_error(signal, message) - ! Wrapper for MOM_error to help place specific break points in - ! debuggers - integer, intent(in) :: signal - character(len=*), intent(in) :: message + ! Wrapper for MOM_error to help place specific break points in debuggers + integer, intent(in) :: signal !< An error severity level, such as FATAL or WARNING + character(len=*), intent(in) :: message !< An error message call MOM_error(signal, message) end subroutine chksum_error +!> Does a bitcount of a number by first casting to an integer and then using BTEST +!! to check bit by bit +integer function bitcount( x ) + real :: x !< Number to be bitcount + + ! Local variables + integer(kind(x)) :: y !< Store the integer representation of the memory used by x + integer :: bit + + bitcount = 0 + y = transfer(x,y) + + ! Fortran standard says that bit indexing start at 0 + do bit = 0, bit_size(y)-1 + if (BTEST(y,bit)) bitcount = bitcount+1 + enddo + +end function bitcount ! ===================================================================== end module MOM_checksums diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index d2a268a741..f8e58d2072 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -45,27 +45,46 @@ module MOM_coms module procedure reproducing_sum_2d, reproducing_sum_3d end interface reproducing_sum -! The Extended Fixed Point (EFP) type provides a public interface for doing -! sums and taking differences with this type. +! The Extended Fixed Point (EFP) type provides a public interface for doing sums +! and taking differences with this type. The use of this type is documented in +! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. +! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. type, public :: EFP_type ; private integer(kind=8), dimension(ni) :: v end type EFP_type -interface operator (+); module procedure EFP_plus ; end interface -interface operator (-); module procedure EFP_minus ; end interface +interface operator (+) ; module procedure EFP_plus ; end interface +interface operator (-) ; module procedure EFP_minus ; end interface interface assignment(=); module procedure EFP_assign ; end interface contains +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 2-D arrays that reproduces across domain decomposition. +!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & overflow_check, err) result(sum) - real, dimension(:,:), intent(in) :: array - integer, optional, intent(in) :: isr, ier, jsr, jer - type(EFP_type), optional, intent(out) :: EFP_sum - logical, optional, intent(in) :: reproducing - logical, optional, intent(in) :: overflow_check - integer, optional, intent(out) :: err - real :: sum ! Result + real, dimension(:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + logical, optional, intent(in) :: reproducing !< If present and false, do the sum + !! using the naive non-reproducing approach + logical, optional, intent(in) :: overflow_check !< If present and false, disable + !! checking for overflows in incremental results. + !! This can speed up calculations if the number + !! of values being summed is small enough + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + real :: sum !< Result ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce @@ -116,20 +135,20 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & if (over_check) then if ((je+1-js)*(ie+1-is) < max_count_prec) then do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) enddo ; enddo call carry_overflow(ints_sum, prec_error) elseif ((ie+1-is) < max_count_prec) then do j=js,je do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) enddo call carry_overflow(ints_sum, prec_error) enddo else do j=js,je ; do i=is,ie call increment_ints(ints_sum, real_to_ints(array(i,j), prec_error), & - prec_error); + prec_error) enddo ; enddo endif else @@ -172,7 +191,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & else rsum(1) = 0.0 do j=js,je ; do i=is,ie - rsum(1) = rsum(1) + array(i,j); + rsum(1) = rsum(1) + array(i,j) enddo ; enddo call sum_across_PEs(rsum,1) sum = rsum(1) @@ -202,14 +221,27 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & end function reproducing_sum_2d +!> This subroutine uses a conversion to an integer representation of real numbers to give an +!! order-invariant sum of distributed 3-D arrays that reproduces across domain decomposition. +!! This technique is described in Hallberg & Adcroft, 2014, Parallel Computing, +!! doi:10.1016/j.parco.2014.04.007. function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & result(sum) - real, dimension(:,:,:), intent(in) :: array - integer, optional, intent(in) :: isr, ier, jsr, jer - real, dimension(:), optional, intent(out) :: sums - type(EFP_type), optional, intent(out) :: EFP_sum - integer, optional, intent(out) :: err - real :: sum ! Result + real, dimension(:,:,:), intent(in) :: array !< The array to be summed + integer, optional, intent(in) :: isr !< The starting i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: ier !< The ending i-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jsr !< The starting j-index of the sum, noting + !! that the array indices starts at 1 + integer, optional, intent(in) :: jer !< The ending j-index of the sum, noting + !! that the array indices starts at 1 + real, dimension(:), optional, intent(out) :: sums !< The sums by vertical layer + type(EFP_type), optional, intent(out) :: EFP_sum !< The result in extended fixed point format + integer, optional, intent(out) :: err !< If present, return an error code instead of + !! triggering any fatal errors directly from + !! this routine. + real :: sum !< Result ! This subroutine uses a conversion to an integer representation ! of real numbers to give order-invariant sums that will reproduce @@ -260,21 +292,21 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (jsz*isz < max_count_prec) then do k=1,ke do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) enddo ; enddo call carry_overflow(ints_sums(:,k), prec_error) enddo elseif (isz < max_count_prec) then do k=1,ke ; do j=js,je do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) enddo call carry_overflow(ints_sums(:,k), prec_error) enddo ; enddo else do k=1,ke ; do j=js,je ; do i=is,ie call increment_ints(ints_sums(:,k), & - real_to_ints(array(i,j,k), prec_error), prec_error); + real_to_ints(array(i,j,k), prec_error), prec_error) enddo ; enddo ; enddo endif if (present(err)) then @@ -318,21 +350,21 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (jsz*isz < max_count_prec) then do k=1,ke do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) enddo ; enddo call carry_overflow(ints_sum, prec_error) enddo elseif (isz < max_count_prec) then do k=1,ke ; do j=js,je do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) enddo call carry_overflow(ints_sum, prec_error) enddo ; enddo else do k=1,ke ; do j=js,je ; do i=is,ie call increment_ints(ints_sum, real_to_ints(array(i,j,k), prec_error), & - prec_error); + prec_error) enddo ; enddo ; enddo endif if (present(err)) then @@ -365,10 +397,15 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & end function reproducing_sum_3d +!> Convert a real number into the array of integers constitute its extended-fixed-point representation function real_to_ints(r, prec_error, overflow) result(ints) - real, intent(in) :: r - integer(kind=8), optional, intent(in) :: prec_error - logical, optional, intent(inout) :: overflow + real, intent(in) :: r !< The real number being converted + integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. + logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being + !! done on a value that is too large to be represented integer(kind=8), dimension(ni) :: ints ! This subroutine converts a real number to an equivalent representation ! using several long integers. @@ -401,8 +438,10 @@ function real_to_ints(r, prec_error, overflow) result(ints) end function real_to_ints +!> Convert the array of integers that constitute an extended-fixed-point +!! representation into a real number function ints_to_real(ints) result(r) - integer(kind=8), dimension(ni), intent(in) :: ints + integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers real :: r ! This subroutine reverses the conversion in real_to_ints. @@ -412,10 +451,15 @@ function ints_to_real(ints) result(r) do i=1,ni ; r = r + pr(i)*ints(i) ; enddo end function ints_to_real +!> Increment an array of integers that constitutes an extended-fixed-point +!! representation with a another EFP number subroutine increment_ints(int_sum, int2, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - integer(kind=8), dimension(ni), intent(in) :: int2 - integer(kind=8), optional, intent(in) :: prec_error + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=8), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=8), optional, intent(in) :: prec_error !!< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints. @@ -441,10 +485,12 @@ subroutine increment_ints(int_sum, int2, prec_error) end subroutine increment_ints +!> Increment an EFP number with a real number without doing any carrying of +!! of overflows and using only minimal error checking. subroutine increment_ints_faster(int_sum, r, max_mag_term) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - real, intent(in) :: r - real, intent(inout) :: max_mag_term + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + real, intent(in) :: r !< The real number being added. + real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's. ! This subroutine increments a number with another, both using the integer ! representation in real_to_ints, but without doing any carrying of overflow. @@ -466,9 +512,14 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) end subroutine increment_ints_faster +!> This subroutine handles carrying of the overflow. subroutine carry_overflow(int_sum, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum - integer(kind=8), intent(in) :: prec_error + integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + !! modified by carries, but without changing value. + integer(kind=8), intent(in) :: prec_error !< The PE-count dependent precision of the + !! integers that is safe from overflows during global + !! sums. This will be larger than the compile-time + !! precision parameter, and is used to detect overflows. ! This subroutine handles carrying of the overflow. integer :: i, num_carry @@ -484,8 +535,13 @@ subroutine carry_overflow(int_sum, prec_error) end subroutine carry_overflow +!> This subroutine carries the overflow, and then makes sure that +!! all integers are of the same sign as the overall value. subroutine regularize_ints(int_sum) - integer(kind=8), dimension(ni), intent(inout) :: int_sum + integer(kind=8), dimension(ni), & + intent(inout) :: int_sum !< The array of integers being modified to take a + !! regular form with all integers of the same sign, + !! but without changing value. ! This subroutine carries the overflow, and then makes sure that ! all integers are of the same sign as the overall value. @@ -521,27 +577,34 @@ subroutine regularize_ints(int_sum) end subroutine regularize_ints +!> Returns the status of the module's error flag function query_EFP_overflow_error() logical :: query_EFP_overflow_error query_EFP_overflow_error = overflow_error end function query_EFP_overflow_error +!> Reset the module's error flag to false subroutine reset_EFP_overflow_error() overflow_error = .false. end subroutine reset_EFP_overflow_error +!> Add two extended-fixed-point numbers function EFP_plus(EFP1, EFP2) - type(EFP_type) :: EFP_plus - type(EFP_type), intent(in) :: EFP1, EFP2 + type(EFP_type) :: EFP_plus !< The result in extended fixed point format + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The second extended fixed point number EFP_plus = EFP1 call increment_ints(EFP_plus%v(:), EFP2%v(:)) end function EFP_plus +!> Subract one extended-fixed-point number from another function EFP_minus(EFP1, EFP2) - type(EFP_type) :: EFP_minus - type(EFP_type), intent(in) :: EFP1, EFP2 + type(EFP_type) :: EFP_minus !< The result in extended fixed point format + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being + !! subtracted from the first extended fixed point number integer :: i do i=1,ni ; EFP_minus%v(i) = -1*EFP2%v(i) ; enddo @@ -549,9 +612,10 @@ function EFP_minus(EFP1, EFP2) call increment_ints(EFP_minus%v(:), EFP1%v(:)) end function EFP_minus +!> Copy one extended-fixed-point number into another subroutine EFP_assign(EFP1, EFP2) - type(EFP_type), intent(out) :: EFP1 - type(EFP_type), intent(in) :: EFP2 + type(EFP_type), intent(out) :: EFP1 !< The recipient extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The source extended fixed point number integer i ! This subroutine assigns all components of the extended fixed point type ! variable on the RHS (EFP2) to the components of the variable on the LHS @@ -560,17 +624,22 @@ subroutine EFP_assign(EFP1, EFP2) do i=1,ni ; EFP1%v(i) = EFP2%v(i) ; enddo end subroutine EFP_assign +!> Return the real number that an extended-fixed-point number corresponds with function EFP_to_real(EFP1) - type(EFP_type), intent(inout) :: EFP1 + type(EFP_type), intent(inout) :: EFP1 !< The extended fixed point number being converted real :: EFP_to_real call regularize_ints(EFP1%v) EFP_to_real = ints_to_real(EFP1%v) end function EFP_to_real +!> Take the difference between two extended-fixed-point numbers (EFP1 - EFP2) +!! and return the result as a real number function EFP_real_diff(EFP1, EFP2) - type(EFP_type), intent(in) :: EFP1, EFP2 - real :: EFP_real_diff + type(EFP_type), intent(in) :: EFP1 !< The first extended fixed point number + type(EFP_type), intent(in) :: EFP2 !< The extended fixed point number being + !! subtracted from the first extended fixed point number + real :: EFP_real_diff !< The real result type(EFP_type) :: EFP_diff @@ -579,9 +648,11 @@ function EFP_real_diff(EFP1, EFP2) end function EFP_real_diff +!> Return the extended-fixed-point number that a real number corresponds with function real_to_EFP(val, overflow) - real, intent(in) :: val - logical, optional, intent(inout) :: overflow + real, intent(in) :: val !< The real number being converted + logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being + !! done on a value that is too large to be represented type(EFP_type) :: real_to_EFP logical :: over @@ -600,10 +671,15 @@ function real_to_EFP(val, overflow) end function real_to_EFP +!< This subroutine does a sum across PEs of a list of EFP variables, +!! returning the sums in place, with all overflows carried. subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) - type(EFP_type), dimension(:), intent(inout) :: EFPs - integer, intent(in) :: nval - logical, dimension(:), optional, intent(out) :: errors + type(EFP_type), dimension(:), & + intent(inout) :: EFPs !< The list of extended fixed point numbers + !! being summed across PEs. + integer, intent(in) :: nval !< The number of values being summed. + logical, dimension(:), & + optional, intent(out) :: errors !< A list of error flags for each sum ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. @@ -645,6 +721,8 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) end subroutine EFP_list_sum_across_PEs +!< This subroutine carries out all of the calls required to close out the infrastructure cleanly. +!! This should only be called in ocean-only runs, as the coupler takes care of this in coupled runs. subroutine MOM_infra_end ! This subroutine should contain all of the calls that are required ! to close out the infrastructure cleanly. This should only be called diff --git a/src/framework/MOM_diag_manager_wrapper.F90 b/src/framework/MOM_diag_manager_wrapper.F90 index 81e26634a7..709fd80a8e 100644 --- a/src/framework/MOM_diag_manager_wrapper.F90 +++ b/src/framework/MOM_diag_manager_wrapper.F90 @@ -6,6 +6,8 @@ module MOM_diag_manager_wrapper use MOM_time_manager, only : time_type use diag_manager_mod, only : register_diag_field +implicit none ; private + public register_diag_field_fms !> A wrapper for register_diag_field_array() @@ -19,20 +21,25 @@ module MOM_diag_manager_wrapper integer function register_diag_field_array_fms(module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or + !! "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - integer, intent(in) :: axes(:) !< Container w/ up to 3 integer handles that indicates axes for this field + integer, intent(in) :: axes(:) !< Container w/ up to 3 integer handles that + !! indicates axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be + !! interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) integer, optional, intent(in) :: area !< The FMS id of cell area integer, optional, intent(in) :: volume !< The FMS id of cell volume @@ -50,7 +57,8 @@ end function register_diag_field_array_fms integer function register_diag_field_scalar_fms(module_name, field_name, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count, area, volume) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. @@ -58,11 +66,14 @@ integer function register_diag_field_scalar_fms(module_name, field_name, init_ti character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + character(len=*), optional, intent(out):: err_msg !< String into which an error message might + !! be placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) integer, optional, intent(in) :: area !< The FMS id of cell area (not used for scalars) integer, optional, intent(in) :: volume !< The FMS id of cell volume (not used for scalars) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index cf2b5adcb3..6a148d1878 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -8,7 +8,7 @@ module MOM_diag_mediator !* diag_manager interfaces with additional diagnostic capabilies. * !* * !********+*********+*********+*********+*********+*********+*********+** - +use MOM_checksums, only : chksum_general use MOM_coms, only : PE_here use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE @@ -78,9 +78,12 @@ module MOM_diag_mediator type(diag_ctrl), pointer :: diag_cs => null() !< Circular link back to the main diagnostics control structure !! (Used to avoid passing said structure into every possible call). ! ID's for cell_methods - character(len=9) :: x_cell_method = '' !< Default nature of data representation, if axes group includes x-direction. - character(len=9) :: y_cell_method = '' !< Default nature of data representation, if axes group includes y-direction. - character(len=9) :: v_cell_method = '' !< Default nature of data representation, if axes group includes vertical direction. + character(len=9) :: x_cell_method = '' !< Default nature of data representation, if axes group + !! includes x-direction. + character(len=9) :: y_cell_method = '' !< Default nature of data representation, if axes group + !! includes y-direction. + character(len=9) :: v_cell_method = '' !< Default nature of data representation, if axes group + !! includes vertical direction. ! For remapping integer :: nz = 0 !< Vertical dimension of diagnostic integer :: vertical_coordinate_number = 0 !< Index of the corresponding diag_remap_ctrl for this axis group @@ -90,18 +93,21 @@ module MOM_diag_mediator logical :: is_u_point = .false. !< If true, indicates that this axes group is for a u-point located field. logical :: is_v_point = .false. !< If true, indicates that this axes group is for a v-point located field. logical :: is_layer = .false. !< If true, indicates that this axes group is for a layer vertically-located field. - logical :: is_interface = .false. !< If true, indicates that this axes group is for an interface vertically-located field. - logical :: is_native = .true. !< If true, indicates that this axes group is for a native model grid. False for any other - !! grid. Used for rank>2. - logical :: needs_remapping = .false. !< If true, indicates that this axes group is for a intensive layer-located field - !! that must be remapped to these axes. Used for rank>2. - logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled interface-located field - !! that must be interpolated to these axes. Used for rank>2. + logical :: is_interface = .false. !< If true, indicates that this axes group is for an interface + !! vertically-located field. + logical :: is_native = .true. !< If true, indicates that this axes group is for a native model grid. + !! False for any other grid. Used for rank>2. + logical :: needs_remapping = .false. !< If true, indicates that this axes group is for a intensive layer-located + !! field that must be remapped to these axes. Used for rank>2. + logical :: needs_interpolating = .false. !< If true, indicates that this axes group is for a sampled + !! interface-located field that must be interpolated to + !! these axes. Used for rank>2. ! For horizontally averaged diagnositcs (applies to 2d and 3d fields only) type(axes_grp), pointer :: xyave_axes => null() !< The associated 1d axes for horizontall area-averaged diagnostics ! ID's for cell_measures integer :: id_area = -1 !< The diag_manager id for area to be used for cell_measure of variables with this axes_grp. - integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables with this axes_grp. + integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables + !! with this axes_grp. ! For masking real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes @@ -129,18 +135,22 @@ module MOM_diag_mediator logical :: in_use !< True if this entry is being used. integer :: fms_diag_id !< Underlying FMS diag_manager id. integer :: fms_xyave_diag_id = -1 !< For a horizontally area-averaged diagnostic. - character(32) :: debug_str = '' !< For FATAL errors and debugging. + character(64) :: debug_str = '' !< For FATAL errors and debugging. type(axes_grp), pointer :: axes => null() type(diag_type), pointer :: next => null() !< Pointer to the next diag. real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. - logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). False for intensive (concentrations). + logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). + !! False for intensive (concentrations). end type diag_type !> The following data type a list of diagnostic fields an their variants, !! as well as variables that control the handling of model output. type, public :: diag_ctrl - integer :: doc_unit = -1 !< The unit number of a diagnostic documentation file. - !! This file is open if doc_unit is > 0. + integer :: available_diag_doc_unit = -1 !< The unit number of a diagnostic documentation file. + !! This file is open if available_diag_doc_unit is > 0. + integer :: chksum_diag_doc_unit = -1 !< The unit number of a diagnostic documentation file. + !! This file is open if available_diag_doc_unit is > 0. + logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics ! The following fields are used for the output of the data. integer :: is, ie, js, je @@ -232,7 +242,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical - if(G%symmetric) then + if (G%symmetric) then id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & 'q point nominal longitude', Domain2=G%Domain%mpp_domain) id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & @@ -344,7 +354,8 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) is_h_point=.true., is_layer=.true., is_native=.false., needs_remapping=.true., & xyave_axes=diag_cs%remap_axesZL(i)) - !! \note Remapping for B points is not yet implemented so needs_remapping is not provided for remap_axesBL + !! \note Remapping for B points is not yet implemented so needs_remapping is not + !! provided for remap_axesBL call define_axes_group(diag_cs, (/ id_xq, id_yq, id_zL /), diag_cs%remap_axesBL(i), & nz=nz, vertical_coordinate_number=i, & x_cell_method='point', y_cell_method='point', v_cell_method='mean', & @@ -581,21 +592,34 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num type(axes_grp), intent(out) :: axes !< The group of 1D axes integer, optional, intent(in) :: nz !< Number of layers in this diagnostic grid integer, optional, intent(in) :: vertical_coordinate_number !< Index number for vertical coordinate - character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the "cell_methods" attribute in CF convention - character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the "cell_methods" attribute in CF convention - character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct the "cell_methods" attribute in CF convention - logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point located fields - logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point located fields - logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for u-point located fields - logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for v-point located fields - logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is for a layer vertically-located field. - logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group is for an interface vertically-located field. - logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is for a native model grid. False for any other grid. - logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is for a intensive layer-located field - !! that must be remapped to these axes. Used for rank>2. - logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group is for a sampled interface-located field - !! that must be interpolated to these axes. Used for rank>2. - type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally area-average diagnostics + character(len=*), optional, intent(in) :: x_cell_method !< A x-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: y_cell_method !< A y-direction cell method used to construct the + !! "cell_methods" attribute in CF convention + character(len=*), optional, intent(in) :: v_cell_method !< A vertical direction cell method used to construct + !! the "cell_methods" attribute in CF convention + logical, optional, intent(in) :: is_h_point !< If true, indicates this axes group for h-point + !! located fields + logical, optional, intent(in) :: is_q_point !< If true, indicates this axes group for q-point + !! located fields + logical, optional, intent(in) :: is_u_point !< If true, indicates this axes group for + !! u-point located fields + logical, optional, intent(in) :: is_v_point !< If true, indicates this axes group for + !! v-point located fields + logical, optional, intent(in) :: is_layer !< If true, indicates that this axes group is + !! for a layer vertically-located field. + logical, optional, intent(in) :: is_interface !< If true, indicates that this axes group + !! is for an interface vertically-located field. + logical, optional, intent(in) :: is_native !< If true, indicates that this axes group is + !! for a native model grid. False for any other grid. + logical, optional, intent(in) :: needs_remapping !< If true, indicates that this axes group is + !! for a intensive layer-located field that must + !! be remapped to these axes. Used for rank>2. + logical, optional, intent(in) :: needs_interpolating !< If true, indicates that this axes group + !! is for a sampled interface-located field that must + !! be interpolated to these axes. Used for rank>2. + type(axes_grp), optional, target :: xyave_axes !< The corresponding axes group for horizontally + !! area-average diagnostics ! Local variables integer :: n @@ -667,9 +691,10 @@ subroutine define_axes_group(diag_cs, handles, axes, nz, vertical_coordinate_num end subroutine define_axes_group +!> Set up the array extents for doing diagnostics subroutine set_diag_mediator_grid(G, diag_cs) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(diag_ctrl), intent(inout) :: diag_cs + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output ! Arguments: ! (inout) G - ocean grid structure @@ -682,11 +707,13 @@ subroutine set_diag_mediator_grid(G, diag_cs) end subroutine set_diag_mediator_grid +!> Make a real scalar diagnostic available for averaging or output subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) - integer, intent(in) :: diag_field_id - real, intent(in) :: field - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field !< real value being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Arguments: ! (in) diag_field_id - the id for an output variable returned by a @@ -719,16 +746,18 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_0d +!> Make a real 1-d array diagnostic available for averaging or output subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:) !< 1-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Arguments: ! (in) diag_field_id - id for an output variable returned by a ! previous call to register_diag_field. -! (in) field - 3-d array being offered for output or averaging +! (in) field - 1-d array being offered for output or averaging ! (inout) diag_cs - structure used to regulate diagnostic output ! (in) static - If true, this is a static field that is always offered. @@ -756,12 +785,14 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_1d_k +!> Make a real 2-d array diagnostic available for averaging or output subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:,:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. ! Arguments: ! (in) diag_field_id - id for an output variable returned by a @@ -787,12 +818,14 @@ subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) end subroutine post_data_2d +!> Make a real 2-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) - type(diag_type), intent(in) :: diag - real, target, intent(in) :: field(:,:) - type(diag_ctrl), intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:) + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. ! Arguments: ! (in) diag - structure representing the diagnostic to post @@ -802,8 +835,10 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) ! (in,opt) mask - If present, use this real array as the data mask. real, dimension(:,:), pointer :: locfield => NULL() + character(len=300) :: mesg logical :: used, is_stat - integer :: isv, iev, jsv, jev, i, j + integer :: cszi, cszj, dszi, dszj + integer :: isv, iev, jsv, jev, i, j, chksum is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -814,27 +849,34 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) ! the output data size and assumes that halos are symmetric. isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je - if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then - isv = diag_cs%is ; iev = diag_cs%ie ! Data domain - elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then - isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then - isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ! Computational domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then - isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ! Symmetric computational domain + cszi = diag_cs%ie-diag_cs%is +1 ; dszi = diag_cs%ied-diag_cs%isd +1 + cszj = diag_cs%je-diag_cs%js +1 ; dszj = diag_cs%jed-diag_cs%jsd +1 + if ( size(field,1) == dszi ) then + isv = diag_cs%is ; iev = diag_cs%ie ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = cszi ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_2d_low: peculiar size in i-direction") + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif - if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then - jsv = diag_cs%js ; jev = diag_cs%je ! Data domain - elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then - jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain - elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then - jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ! Computational domain - elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then - jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ! Symmetric computational domain + + if ( size(field,2) == dszj ) then + jsv = diag_cs%js ; jev = diag_cs%je ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ! Computational domain + elseif ( size(field,2) == cszj+1 ) then + jsv = 1 ; jev = cszj+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_2d_low: peculiar size in j-direction") + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_2d_low: "//trim(diag%debug_str)//trim(mesg)) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then @@ -850,35 +892,41 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) else locfield => field endif - - if (is_stat) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & - 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) - !elseif(associated(diag%axes%mask2d)) then - ! used = send_data(diag%fms_diag_id, locfield, & - ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) - else - used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) + if (diag_cs%diag_as_chksum) then + chksum = chksum_general(locfield) + if (is_root_pe()) then + call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) endif - elseif (diag_cs%ave_enabled) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & - 'post_data_2d_low: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=mask) - elseif(associated(diag%axes%mask2d)) then - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%axes%mask2d) - else - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) + else + if (is_stat) then + if (present(mask)) then + call assert(size(locfield) == size(mask), & + 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) + used = send_data(diag%fms_diag_id, locfield, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) + !elseif (associated(diag%axes%mask2d)) then + ! used = send_data(diag%fms_diag_id, locfield, & + ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) + else + used = send_data(diag%fms_diag_id, locfield, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) + endif + elseif (diag_cs%ave_enabled) then + if (present(mask)) then + call assert(size(locfield) == size(mask), & + 'post_data_2d_low: mask size mismatch: '//diag%debug_str) + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int, rmask=mask) + elseif (associated(diag%axes%mask2d)) then + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int, rmask=diag%axes%mask2d) + else + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int) + endif endif endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) & @@ -886,14 +934,18 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) end subroutine post_data_2d_low +!> Make a real 3-d array diagnostic available for averaging or output. subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) - integer, intent(in) :: diag_field_id - real, intent(in) :: field(:,:,:) - type(diag_ctrl), target, intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:,:) - real, target, optional, intent(in) :: alt_h(:,:,:) + integer, intent(in) :: diag_field_id !< The id for an output variable returned by a + !! previous call to register_diag_field. + real, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, dimension(:,:,:), & + target, optional, intent(in) :: alt_h !< An alternate thickness to use for vertically + !! remapping this diagnostic, in H. ! Arguments: ! (in) diag_field_id - id for an output variable returned by a @@ -909,7 +961,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) logical :: staggered_in_x, staggered_in_y real, dimension(:,:,:), pointer :: h_diag - if(present(alt_h)) then + if (present(alt_h)) then h_diag => alt_h else h_diag => diag_cs%h @@ -1009,12 +1061,14 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) end subroutine post_data_3d +!> Make a real 3-d array diagnostic available for averaging or output +!! using a diag_type instead of an integer id. subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) - type(diag_type), intent(in) :: diag - real, target, intent(in) :: field(:,:,:) - type(diag_ctrl), intent(in) :: diag_cs - logical, optional, intent(in) :: is_static - real, optional, intent(in) :: mask(:,:,:) + type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post + real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. ! Arguments: ! (in) diag - the diagnostic to post. @@ -1024,10 +1078,13 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) ! (in,opt) mask - If present, use this real array as the data mask. real, dimension(:,:,:), pointer :: locfield => NULL() + character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y logical :: is_stat + integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c + integer :: chksum is_stat = .false. ; if (present(is_static)) is_stat = is_static @@ -1038,33 +1095,41 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) ! the output data size and assumes that halos are symmetric. isv = diag_cs%is ; iev = diag_cs%ie ; jsv = diag_cs%js ; jev = diag_cs%je - if ( size(field,1) == diag_cs%ied-diag_cs%isd +1 ) then - isv = diag_cs%is ; iev = diag_cs%ie ! Data domain - elseif ( size(field,1) == diag_cs%ied-diag_cs%isd +2 ) then - isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +1 ) then - isv = 1 ; iev = diag_cs%ie + 1-diag_cs%is ! Computational domain - elseif ( size(field,1) == diag_cs%ie-diag_cs%is +2 ) then - isv = 1 ; iev = diag_cs%ie + 2-diag_cs%is ! Symmetric computational domain + cszi = (diag_cs%ie-diag_cs%is) +1 ; dszi = (diag_cs%ied-diag_cs%isd) +1 + cszj = (diag_cs%je-diag_cs%js) +1 ; dszj = (diag_cs%jed-diag_cs%jsd) +1 + if ( size(field,1) == dszi ) then + isv = diag_cs%is ; iev = diag_cs%ie ! Data domain + elseif ( size(field,1) == dszi + 1 ) then + isv = diag_cs%is ; iev = diag_cs%ie+1 ! Symmetric data domain + elseif ( size(field,1) == cszi) then + isv = 1 ; iev = cszi ! Computational domain + elseif ( size(field,1) == cszi + 1 ) then + isv = 1 ; iev = cszi+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_3d_low: peculiar size in i-direction") + write (mesg,*) " peculiar size ",size(field,1)," in i-direction\n"//& + "does not match one of ", cszi, cszi+1, dszi, dszi+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) endif - if ( size(field,2) == diag_cs%jed-diag_cs%jsd +1 ) then - jsv = diag_cs%js ; jev = diag_cs%je ! Data domain - elseif ( size(field,2) == diag_cs%jed-diag_cs%jsd +2 ) then - jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain - elseif ( size(field,2) == diag_cs%je-diag_cs%js +1 ) then - jsv = 1 ; jev = diag_cs%je + 1-diag_cs%js ! Computational domain - elseif ( size(field,1) == diag_cs%je-diag_cs%js +2 ) then - jsv = 1 ; jev = diag_cs%je + 2-diag_cs%js ! Symmetric computational domain + + if ( size(field,2) == dszj ) then + jsv = diag_cs%js ; jev = diag_cs%je ! Data domain + elseif ( size(field,2) == dszj + 1 ) then + jsv = diag_cs%js ; jev = diag_cs%je+1 ! Symmetric data domain + elseif ( size(field,2) == cszj ) then + jsv = 1 ; jev = cszj ! Computational domain + elseif ( size(field,2) == cszj+1 ) then + jsv = 1 ; jev = cszj+1 ! Symmetric computational domain else - call MOM_error(FATAL,"post_data_3d_low: peculiar size in j-direction") + write (mesg,*) " peculiar size ",size(field,2)," in j-direction\n"//& + "does not match one of ", cszj, cszj+1, dszj, dszj+1 + call MOM_error(FATAL,"post_data_3d_low: "//trim(diag%debug_str)//trim(mesg)) endif if ((diag%conversion_factor /= 0.) .and. (diag%conversion_factor /= 1.)) then ks = lbound(field,3) ; ke = ubound(field,3) allocate( locfield( lbound(field,1):ubound(field,1), lbound(field,2):ubound(field,2), ks:ke ) ) - ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears not to be necessary. + ! locfield(:,:,:) = 0.0 ! Zeroing out this array would be a good idea, but it appears + ! not to be necessary. isv_c = isv ; jsv_c = jsv if (diag%fms_xyave_diag_id>0) then staggered_in_x = diag%axes%is_u_point .or. diag%axes%is_q_point @@ -1092,36 +1157,43 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) endif if (diag%fms_diag_id>0) then - if (is_stat) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & - 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) - !elseif(associated(diag%axes%mask3d)) then - ! used = send_data(diag_field_id, locfield, & - ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask3d) - else - used = send_data(diag%fms_diag_id, locfield, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) + if (diag_cs%diag_as_chksum) then + chksum = chksum_general(locfield) + if (is_root_pe()) then + call log_chksum_diag(diag_cs%chksum_diag_doc_unit, diag%debug_str, chksum) endif - elseif (diag_cs%ave_enabled) then - if (present(mask)) then - call assert(size(locfield) == size(mask), & - 'post_data_3d_low: mask size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=mask) - elseif(associated(diag%axes%mask3d)) then - call assert(size(locfield) == size(diag%axes%mask3d), & - 'post_data_3d_low: mask3d size mismatch: '//diag%debug_str) - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int, rmask=diag%axes%mask3d) - else - used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & - is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & - weight=diag_cs%time_int) + else + if (is_stat) then + if (present(mask)) then + call assert(size(locfield) == size(mask), & + 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) + used = send_data(diag%fms_diag_id, locfield, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) + !elseif (associated(diag%axes%mask3d)) then + ! used = send_data(diag_field_id, locfield, & + ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask3d) + else + used = send_data(diag%fms_diag_id, locfield, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev) + endif + elseif (diag_cs%ave_enabled) then + if (present(mask)) then + call assert(size(locfield) == size(mask), & + 'post_data_3d_low: mask size mismatch: '//diag%debug_str) + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int, rmask=mask) + elseif (associated(diag%axes%mask3d)) then + call assert(size(locfield) == size(diag%axes%mask3d), & + 'post_data_3d_low: mask3d size mismatch: '//diag%debug_str) + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int, rmask=diag%axes%mask3d) + else + used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & + is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & + weight=diag_cs%time_int) + endif endif endif endif @@ -1178,10 +1250,12 @@ subroutine post_xy_average(diag_cs, diag, field) weight=diag_cs%time_int) end subroutine post_xy_average +!> This subroutine enables the accumulation of time averages over the specified time interval. subroutine enable_averaging(time_int_in, time_end_in, diag_cs) - real, intent(in) :: time_int_in - type(time_type), intent(in) :: time_end_in - type(diag_ctrl), intent(inout) :: diag_cs + real, intent(in) :: time_int_in !< The time interval in s over which any + !! values that are offered are valid. + type(time_type), intent(in) :: time_end_in !< The end time of the valid interval + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output ! This subroutine enables the accumulation of time averages over the ! specified time interval. @@ -1189,7 +1263,7 @@ subroutine enable_averaging(time_int_in, time_end_in, diag_cs) ! Arguments: ! (in) time_int_in - time interval in s over which any ! values that are offered are valid. -! (in) time_end_in - end time in s of the valid interval +! (in) time_end_in - end time of the valid interval ! (inout) diag - structure used to regulate diagnostic output ! if (num_file==0) return @@ -1198,9 +1272,9 @@ subroutine enable_averaging(time_int_in, time_end_in, diag_cs) diag_cs%ave_enabled = .true. end subroutine enable_averaging -! Call this subroutine to avoid averaging any offered fields. +!> Call this subroutine to avoid averaging any offered fields. subroutine disable_averaging(diag_cs) - type(diag_ctrl), intent(inout) :: diag_cs + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output ! Argument: ! diag - structure used to regulate diagnostic output @@ -1210,12 +1284,12 @@ subroutine disable_averaging(diag_cs) end subroutine disable_averaging -! Call this subroutine to determine whether the averaging is -! currently enabled. .true. is returned if it is. +!> Call this subroutine to determine whether the averaging is +!! currently enabled. .true. is returned if it is. function query_averaging_enabled(diag_cs, time_int, time_end) - type(diag_ctrl), intent(in) :: diag_cs - real, optional, intent(out) :: time_int - type(time_type), optional, intent(out) :: time_end + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output + real, optional, intent(out) :: time_int !< Current setting of diag%time_int, in s + type(time_type), optional, intent(out) :: time_end !< Current setting of diag%time_end logical :: query_averaging_enabled ! Arguments: @@ -1228,62 +1302,71 @@ function query_averaging_enabled(diag_cs, time_int, time_end) query_averaging_enabled = diag_cs%ave_enabled end function query_averaging_enabled +!> This function returns the valid end time for use with diagnostics that are +!! handled outside of the MOM6 diagnostics infrastructure. function get_diag_time_end(diag_cs) - type(diag_ctrl), intent(in) :: diag_cs + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(time_type) :: get_diag_time_end - -! Argument: -! (in) diag - structure used to regulate diagnostic output - -! This function returns the valid end time for diagnostics that are handled -! outside of the MOM6 infrastructure, such as via the generic tracer code. + ! This function returns the valid end time for diagnostics that are handled + ! outside of the MOM6 infrastructure, such as via the generic tracer code. get_diag_time_end = diag_cs%time_end end function get_diag_time_end -!> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics derived from one field. +!> Returns the "diag_mediator" handle for a group (native, CMOR, z-coord, ...) of diagnostics +!! derived from one field. integer function register_diag_field(module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count, cmor_field_name, & cmor_long_name, cmor_units, cmor_standard_name, cell_methods, & x_cell_method, y_cell_method, v_cell_method, conversion, v_extensive) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + !! indicates axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field 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 - character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. - !! If present, this overrides the default constructed from the default for + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to + !! have no attribute. If present, this overrides the + !! default constructed from the default for !! each individual axis direction. - character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. - character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. - character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically integrated). Default/absent for intensive. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically + !! integrated). Default/absent for intensive. ! Local variables real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => NULL() type(axes_grp), pointer :: remap_axes => null() integer :: dm_id, i character(len=256) :: new_module_name logical :: active MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs dm_id = -1 @@ -1307,21 +1390,21 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & ! Register diagnostics remapped to z vertical coordinate if (axes%rank == 3) then remap_axes => null() - if ((axes%id .eq. diag_cs%axesTL%id)) then + if ((axes%id == diag_cs%axesTL%id)) then remap_axes => diag_cs%remap_axesTL(i) - elseif(axes%id .eq. diag_cs%axesBL%id) then + elseif (axes%id == diag_cs%axesBL%id) then remap_axes => diag_cs%remap_axesBL(i) - elseif(axes%id .eq. diag_cs%axesCuL%id ) then + elseif (axes%id == diag_cs%axesCuL%id ) then remap_axes => diag_cs%remap_axesCuL(i) - elseif(axes%id .eq. diag_cs%axesCvL%id) then + elseif (axes%id == diag_cs%axesCvL%id) then remap_axes => diag_cs%remap_axesCvL(i) - elseif(axes%id .eq. diag_cs%axesTi%id) then + elseif (axes%id == diag_cs%axesTi%id) then remap_axes => diag_cs%remap_axesTi(i) - elseif(axes%id .eq. diag_cs%axesBi%id) then + elseif (axes%id == diag_cs%axesBi%id) then remap_axes => diag_cs%remap_axesBi(i) - elseif(axes%id .eq. diag_cs%axesCui%id ) then + elseif (axes%id == diag_cs%axesCui%id ) then remap_axes => diag_cs%remap_axesCui(i) - elseif(axes%id .eq. diag_cs%axesCvi%id) then + elseif (axes%id == diag_cs%axesCvi%id) then remap_axes => diag_cs%remap_axesCvi(i) endif ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will @@ -1361,40 +1444,49 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes + !! for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided + !! with post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field 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 - character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. - !! If present, this overrides the default constructed from the default for - !! each individual axis direction. - character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. - character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. - character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically integrated). Default/absent for intensive. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically + !! integrated). Default/absent for intensive. ! Local variables real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: this_diag => null() integer :: fms_id, fms_xyave_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value register_diag_field_expand_cmor = .false. diag_cs => axes%diag_cs @@ -1408,7 +1500,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, call attach_cell_methods(fms_id, axes, cm_string, & cell_methods, x_cell_method, y_cell_method, v_cell_method, & v_extensive=v_extensive) - if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then msg = '' if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'"' call log_available_diag(fms_id>0, module_name, field_name, cm_string, & @@ -1425,7 +1517,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, interp_method=interp_method, tile_count=tile_count) call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, & cell_methods, v_cell_method, v_extensive=v_extensive) - if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then msg = '' if (present(cmor_field_name)) msg = 'CMOR equivalent is "'//trim(cmor_field_name)//'_xyave"' call log_available_diag(fms_xyave_id>0, module_name, trim(field_name)//'_xyave', cm_string, & @@ -1445,9 +1537,9 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, ! For the CMOR variation of the above diagnostic if (present(cmor_field_name)) then ! Fallback values for strings set to "NULL" - posted_cmor_units = "not provided" ! - posted_cmor_standard_name = "not provided" ! Values might be able to be replaced with a CS%missing field? - posted_cmor_long_name = "not provided" ! + posted_cmor_units = "not provided" ! + posted_cmor_standard_name = "not provided" ! Values might be able to be replaced with a CS%missing field? + posted_cmor_long_name = "not provided" ! ! If attributes are present for MOM variable names, use them first for the register_diag_field ! call for CMOR verison of the variable @@ -1461,14 +1553,14 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (present(cmor_long_name)) posted_cmor_long_name = cmor_long_name fms_id = register_diag_field_expand_axes(module_name, cmor_field_name, axes, init_time, & - long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & - missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & - standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & err_msg=err_msg, interp_method=interp_method, tile_count=tile_count) call attach_cell_methods(fms_id, axes, cm_string, & cell_methods, x_cell_method, y_cell_method, v_cell_method, & v_extensive=v_extensive) - if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then msg = 'native name is "'//trim(field_name)//'"' call log_available_diag(fms_id>0, module_name, cmor_field_name, cm_string, & msg, diag_CS, posted_cmor_long_name, posted_cmor_units, & @@ -1479,16 +1571,16 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, if (associated(axes%xyave_axes)) then fms_xyave_id = register_diag_field_expand_axes(module_name, trim(cmor_field_name)//'_xyave', & axes%xyave_axes, init_time, & - long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & - missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & - standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & + long_name=trim(posted_cmor_long_name), units=trim(posted_cmor_units), & + missing_value=MOM_missing_value, range=range, mask_variant=mask_variant, & + standard_name=trim(posted_cmor_standard_name), verbose=verbose, do_not_log=do_not_log, & err_msg=err_msg, interp_method=interp_method, tile_count=tile_count) call attach_cell_methods(fms_xyave_id, axes%xyave_axes, cm_string, & cell_methods, v_cell_method, v_extensive=v_extensive) - if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then msg = 'native name is "'//trim(field_name)//'_xyave"' - call log_available_diag(fms_xyave_id>0, module_name, trim(cmor_field_name)//'_xyave', cm_string, & - msg, diag_CS, posted_cmor_long_name, posted_cmor_units, & + call log_available_diag(fms_xyave_id>0, module_name, trim(cmor_field_name)//'_xyave', & + cm_string, msg, diag_CS, posted_cmor_long_name, posted_cmor_units, & posted_cmor_standard_name) endif endif @@ -1505,25 +1597,31 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, end function register_diag_field_expand_cmor -!> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes (axes-group) -!! into handles and conditionally adding an FMS area_id for cell_measures. +!> Returns an FMS id from register_diag_field_fms (the diag_manager routine) after expanding axes +!! (axes-group) into handles and conditionally adding an FMS area_id for cell_measures. integer function register_diag_field_expand_axes(module_name, field_name, axes, init_time, & long_name, units, missing_value, range, mask_variant, standard_name, & verbose, do_not_log, err_msg, interp_method, tile_count) - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field type(time_type), intent(in) :: init_time !< Time at which a field is first available? character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field real, optional, intent(in) :: missing_value !< A value that indicates missing values. real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) - logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with post_data calls (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided + !! with post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) - logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) - character(len=*), optional, intent(out):: err_msg !< String into which an error message might be placed (not used in MOM?) - character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not be interpolated as a scalar + logical, optional, intent(in) :: do_not_log !< If true, do not log something + !! (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should + !! not be interpolated as a scalar integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) ! Local variables integer :: fms_id, area_id, volume_id @@ -1607,8 +1705,10 @@ subroutine add_diag_to_list(diag_cs, dm_id, fms_id, this_diag, axes, module_name integer, intent(inout) :: dm_id !< The diag_mediator ID for this diagnostic group integer, intent(in) :: fms_id !< The FMS diag_manager ID for this diagnostic type(diag_type), pointer :: this_diag !< This diagnostic - type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field - character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" or "ice_shelf_model" + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + !! indicates axes for this field + character(len=*), intent(in) :: module_name !< Name of this module, usually + !! "ocean_model" or "ice_shelf_model" character(len=*), intent(in) :: field_name !< Name of diagnostic character(len=*), intent(in) :: msg !< Message for errors @@ -1628,15 +1728,21 @@ end subroutine add_diag_to_list subroutine attach_cell_methods(id, axes, ostring, cell_methods, & x_cell_method, y_cell_method, v_cell_method, v_extensive) integer, intent(in) :: id !< Handle to diagnostic - type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates axes for this field + type(axes_grp), intent(in) :: axes !< Container w/ up to 3 integer handles that indicates + !! axes for this field character(len=*), intent(out) :: ostring !< The cell_methods strings that would appear in the file - character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. Use '' to have no attribute. - !! If present, this overrides the default constructed from the default for - !! each individual axis direction. - character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. Use '' have no method. - character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. Use '' have no method. - character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. Use '' have no method. - logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically integrated). Default/absent for intensive. + character(len=*), optional, intent(in) :: cell_methods !< String to append as cell_methods attribute. + !! Use '' to have no attribute. If present, this + !! overrides the default constructed from the default + !! for each individual axis direction. + character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. + !! Use '' have no method. + character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. + !! Use '' have no method. + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields + !! (vertically integrated). Default/absent for intensive. ! Local variables character(len=9) :: axis_name logical :: x_mean, y_mean, x_sum, y_sum @@ -1739,16 +1845,25 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & do_not_log, err_msg, interp_method, cmor_field_name, & cmor_long_name, cmor_units, cmor_standard_name) integer :: register_scalar_field - character(len=*), intent(in) :: module_name, field_name - type(time_type), intent(in) :: init_time - type(diag_ctrl), intent(inout) :: diag_cs - character(len=*), optional, intent(in) :: long_name, units, standard_name - real, optional, intent(in) :: missing_value, range(2) - logical, optional, intent(in) :: do_not_log - character(len=*), optional, intent(out):: err_msg - character(len=*), optional, intent(in) :: interp_method - character(len=*), optional, intent(in) :: cmor_field_name, cmor_long_name - character(len=*), optional, intent(in) :: cmor_units, cmor_standard_name + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(time_type), intent(in) :: init_time !< Time at which a field is first available? + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(out):: err_msg !< String into which an error message might be + !! placed (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + 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 ! Output: An integer handle for a diagnostic array. ! Arguments: @@ -1775,7 +1890,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name MOM_missing_value = diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value dm_id = -1 diag => null() @@ -1824,7 +1939,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & endif ! Document diagnostics in list of available diagnostics - if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & long_name, units, standard_name) if (present(cmor_field_name)) then @@ -1845,15 +1960,26 @@ function register_static_field(module_name, field_name, axes, & cmor_field_name, cmor_long_name, cmor_units, cmor_standard_name, area, & x_cell_method, y_cell_method, area_cell_method) integer :: register_static_field - character(len=*), intent(in) :: module_name, field_name - type(axes_grp), target, intent(in) :: axes - character(len=*), optional, intent(in) :: long_name, units, standard_name - real, optional, intent(in) :: missing_value, range(2) - logical, optional, intent(in) :: mask_variant, do_not_log - character(len=*), optional, intent(in) :: interp_method - integer, optional, intent(in) :: tile_count - character(len=*), optional, intent(in) :: cmor_field_name, cmor_long_name - character(len=*), optional, intent(in) :: cmor_units, cmor_standard_name + character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" + !! or "ice_shelf_model" + character(len=*), intent(in) :: field_name !< Name of the diagnostic field + type(axes_grp), target, intent(in) :: axes !< Container w/ up to 3 integer handles that + !! indicates axes for this field + character(len=*), optional, intent(in) :: long_name !< Long name of a field. + character(len=*), optional, intent(in) :: units !< Units of a field. + character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field + real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with + !! post_data calls (not used in MOM?) + logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) + character(len=*), optional, intent(in) :: interp_method !< If 'none' indicates the field should not + !! be interpolated as a scalar + integer, optional, intent(in) :: tile_count !< no clue (not used in MOM?) + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name of a field + 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 integer, optional, intent(in) :: area !< fms_id for area_t character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. @@ -1877,14 +2003,14 @@ function register_static_field(module_name, field_name, axes, & ! (in,opt) tile_count - no clue real :: MOM_missing_value - type(diag_ctrl), pointer :: diag_cs + type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: diag => null(), cmor_diag => null() integer :: dm_id, fms_id, cmor_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name character(len=9) :: axis_name MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs dm_id = -1 @@ -1959,7 +2085,7 @@ function register_static_field(module_name, field_name, axes, & endif ! Document diagnostics in list of available diagnostics - if (is_root_pe() .and. diag_CS%doc_unit > 0) then + if (is_root_pe() .and. diag_CS%available_diag_doc_unit > 0) then call log_available_diag(associated(diag), module_name, field_name, '', '', diag_CS, & long_name, units, standard_name) if (present(cmor_field_name)) then @@ -1973,9 +2099,11 @@ function register_static_field(module_name, field_name, axes, & end function register_static_field +!> Describe an option setting in the diagnostic files. subroutine describe_option(opt_name, value, diag_CS) - character(len=*), intent(in) :: opt_name, value - type(diag_ctrl), intent(in) :: diag_CS + character(len=*), intent(in) :: opt_name !< The name of the option + character(len=*), intent(in) :: value !< A character string with the setting of the option. + type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output character(len=240) :: mesg integer :: len_ind @@ -1983,7 +2111,7 @@ subroutine describe_option(opt_name, value, diag_CS) len_ind = len_trim(value) ! Add error handling for long values? mesg = " ! "//trim(opt_name)//": "//trim(value) - write(diag_CS%doc_unit, '(a)') trim(mesg) + write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) end subroutine describe_option !> Registers a diagnostic using the information encapsulated in the vardesc @@ -2088,13 +2216,13 @@ function ocean_register_diag(var_desc, G, diag_CS, day) end select ocean_register_diag = register_diag_field("ocean_model", trim(var_name), & - axes, day, trim(longname), trim(units), missing_value = -1.0e+34) + axes, day, trim(longname), trim(units), missing_value=-1.0e+34) end function ocean_register_diag subroutine diag_mediator_infrastructure_init(err_msg) ! This subroutine initializes the FMS diag_manager. - character(len=*), optional, intent(out) :: err_msg + character(len=*), optional, intent(out) :: err_msg !< An error message call diag_manager_init(err_msg=err_msg) end subroutine diag_mediator_infrastructure_init @@ -2167,6 +2295,10 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) call get_param(param_file, mod, 'DIAG_MISVAL', diag_cs%missing_value, & 'Set the default missing value to use for diagnostics.', & default=1.e20) + call get_param(param_file, mod, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, & + 'Instead of writing diagnostics to the diag manager, write\n' //& + 'a textfile containing the checksum (bitcount) of the array.', & + default=.false.) ! Keep pointers grid, h, T, S needed diagnostic remapping diag_cs%G => G @@ -2186,15 +2318,16 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) diag_cs%isd = G%isd ; diag_cs%ied = G%ied diag_cs%jsd = G%jsd ; diag_cs%jed = G%jed - if (is_root_pe() .and. (diag_CS%doc_unit < 0)) then + ! Initialze available diagnostic log file + if (is_root_pe() .and. (diag_CS%available_diag_doc_unit < 0)) then write(this_pe,'(i6.6)') PE_here() doc_file_dflt = "available_diags."//this_pe call get_param(param_file, mod, "AVAILABLE_DIAGS_FILE", doc_file, & "A file into which to write a list of all available \n"//& "ocean diagnostics that can be included in a diag_table.", & - default=doc_file_dflt, do_not_log=(diag_CS%doc_unit/=-1)) + default=doc_file_dflt, do_not_log=(diag_CS%available_diag_doc_unit/=-1)) if (len_trim(doc_file) > 0) then - new_file = .true. ; if (diag_CS%doc_unit /= -1) new_file = .false. + new_file = .true. ; if (diag_CS%available_diag_doc_unit /= -1) new_file = .false. ! Find an unused unit number. do new_unit=512,42,-1 inquire( new_unit, opened=opened) @@ -2208,34 +2341,69 @@ subroutine diag_mediator_init(G, GV, nz, param_file, diag_cs, doc_file_dir) doc_path = trim(slasher(doc_file_dir))//trim(doc_file) endif ; endif - diag_CS%doc_unit = new_unit + diag_CS%available_diag_doc_unit = new_unit if (new_file) then - open(diag_CS%doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + open(diag_CS%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & action='WRITE', status='REPLACE', iostat=ios) else ! This file is being reopened, and should be appended. - open(diag_CS%doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + open(diag_CS%available_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & action='WRITE', status='OLD', position='APPEND', iostat=ios) endif - inquire(diag_CS%doc_unit, opened=opened) + inquire(diag_CS%available_diag_doc_unit, opened=opened) if ((.not.opened) .or. (ios /= 0)) then call MOM_error(FATAL, "Failed to open available diags file "//trim(doc_path)//".") endif endif endif -end subroutine diag_mediator_init + if (is_root_pe() .and. (diag_CS%chksum_diag_doc_unit < 0) .and. diag_CS%diag_as_chksum) then + write(this_pe,'(i6.6)') PE_here() + doc_file_dflt = "chksum_diag."//this_pe + call get_param(param_file, mod, "CHKSUM_DIAG_FILE", doc_file, & + "A file into which to write all checksums of the \n"//& + "diagnostics listed in the diag_table.", & + default=doc_file_dflt, do_not_log=(diag_CS%chksum_diag_doc_unit/=-1)) + if (len_trim(doc_file) > 0) then + new_file = .true. ; if (diag_CS%chksum_diag_doc_unit /= -1) new_file = .false. + ! Find an unused unit number. + do new_unit=512,42,-1 + inquire( new_unit, opened=opened) + if (.not.opened) exit + enddo + if (opened) call MOM_error(FATAL, & + "diag_mediator_init failed to find an unused unit number.") -subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) + doc_path = doc_file + if (present(doc_file_dir)) then ; if (len_trim(doc_file_dir) > 0) then + doc_path = trim(slasher(doc_file_dir))//trim(doc_file) + endif ; endif + + diag_CS%chksum_diag_doc_unit = new_unit + + if (new_file) then + open(diag_CS%chksum_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='REPLACE', iostat=ios) + else ! This file is being reopened, and should be appended. + open(diag_CS%chksum_diag_doc_unit, file=trim(doc_path), access='SEQUENTIAL', form='FORMATTED', & + action='WRITE', status='OLD', position='APPEND', iostat=ios) + endif + inquire(diag_CS%chksum_diag_doc_unit, opened=opened) + if ((.not.opened) .or. (ios /= 0)) then + call MOM_error(FATAL, "Failed to open checksum diags file "//trim(doc_path)//".") + endif + endif + endif - real, dimension(:,:,:), target, intent(in) :: h, T, S - type(EOS_type), pointer, intent(in) :: eqn_of_state !< Equation of state structure - type(diag_ctrl), intent(inout) :: diag_cs +end subroutine diag_mediator_init - ! (inout) diag_cs - diag mediator control structure - ! (in) h - a pointer to model thickness - ! (in) T - a pointer to model temperature - ! (in) S - a pointer to model salinity +!> Set pointers to the default state fields used to remap diagnostics. +subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) + real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array + real, dimension(:,:,:), target, intent(in ) :: T !< the model temperature array + real, dimension(:,:,:), target, intent(in ) :: S !< the model salinity array + type(EOS_type), target, intent(in ) :: eqn_of_state !< Equation of state structure + type(diag_ctrl), intent(inout) :: diag_cs !< diag mediator control structure ! Keep pointers to h, T, S needed for the diagnostic remapping diag_cs%h => h @@ -2342,12 +2510,12 @@ subroutine diag_masks_set(G, nz, diag_cs) end subroutine diag_masks_set subroutine diag_mediator_close_registration(diag_CS) - type(diag_ctrl), intent(inout) :: diag_CS + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output integer :: i - if (diag_CS%doc_unit > -1) then - close(diag_CS%doc_unit) ; diag_CS%doc_unit = -2 + if (diag_CS%available_diag_doc_unit > -1) then + close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -2 endif do i=1, diag_cs%num_diag_coords @@ -2357,15 +2525,18 @@ subroutine diag_mediator_close_registration(diag_CS) end subroutine diag_mediator_close_registration subroutine diag_mediator_end(time, diag_CS, end_diag_manager) - type(time_type), intent(in) :: time - type(diag_ctrl), intent(inout) :: diag_cs + type(time_type), intent(in) :: time !< The current model time + type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: end_diag_manager !< If true, call diag_manager_end() ! Local variables integer :: i - if (diag_CS%doc_unit > -1) then - close(diag_CS%doc_unit) ; diag_CS%doc_unit = -3 + if (diag_CS%available_diag_doc_unit > -1) then + close(diag_CS%available_diag_doc_unit) ; diag_CS%available_diag_doc_unit = -3 + endif + if (diag_CS%chksum_diag_doc_unit > -1) then + close(diag_CS%chksum_diag_doc_unit) ; diag_CS%chksum_diag_doc_unit = -3 endif deallocate(diag_cs%diags) @@ -2394,24 +2565,26 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) end subroutine diag_mediator_end +!> Convert the first n elements (up to 3) of an integer array to an underscore delimited string. function i2s(a,n_in) -! "Convert the first n elements of an integer array to a string." - integer, dimension(:), intent(in) :: a - integer, optional , intent(in) :: n_in - character(len=15) :: i2s - - character(len=15) :: i2s_temp - integer :: i,n - - n=size(a) - if(present(n_in)) n = n_in - - i2s = '' - do i=1,n - write (i2s_temp, '(I4.4)') a(i) - i2s = trim(i2s) //'_'// trim(i2s_temp) - enddo - i2s = adjustl(i2s) + ! "Convert the first n elements of an integer array to a string." + ! Perhaps this belongs elsewhere in the MOM6 code? + integer, dimension(:), intent(in) :: a !< The array of integers to translate + integer, optional , intent(in) :: n_in !< The number of elements to translate, by default all + character(len=15) :: i2s !< The returned string + + character(len=15) :: i2s_temp + integer :: i,n + + n=size(a) + if (present(n_in)) n = n_in + + i2s = '' + do i=1,min(n,3) + write (i2s_temp, '(I4.4)') a(i) + i2s = trim(i2s) //'_'// trim(i2s_temp) + enddo + i2s = adjustl(i2s) end function i2s !> Returns a new diagnostic id, it may be necessary to expand the diagnostics array. @@ -2457,17 +2630,12 @@ subroutine initialize_diag_type(diag) end subroutine initialize_diag_type -! Make a new diagnostic. Either use memory which is in the array of 'primary' -! diagnostics, or if that is in use, insert it to the list of secondary diags. +!> Make a new diagnostic. Either use memory which is in the array of 'primary' +!! diagnostics, or if that is in use, insert it to the list of secondary diags. subroutine alloc_diag_with_id(diag_id, diag_cs, diag) - integer, intent(in) :: diag_id - type(diag_ctrl), target, intent(inout) :: diag_cs - type(diag_type), pointer, intent(out) :: diag - - ! Arguments: - ! (in) diag_id - new id for the diag. - ! (inout) diag_cs - structure used to regulate diagnostic output - ! (inout) diag - structure representing a diagnostic + integer, intent(in ) :: diag_id !< id for the diagnostic + type(diag_ctrl), target, intent(inout) :: diag_cs !< structure used to regulate diagnostic output + type(diag_type), pointer :: diag !< structure representing a diagnostic (inout) type(diag_type), pointer :: tmp @@ -2504,9 +2672,9 @@ subroutine log_available_diag(used, module_name, field_name, cell_methods_string mesg = '"'//trim(module_name)//'", "'//trim(field_name)//'" [Unused]' endif if (len(trim((comment)))>0) then - write(diag_CS%doc_unit, '(a,x,"(",a,")")') trim(mesg),trim(comment) + write(diag_CS%available_diag_doc_unit, '(a,x,"(",a,")")') trim(mesg),trim(comment) else - write(diag_CS%doc_unit, '(a)') trim(mesg) + write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) endif if (present(long_name)) call describe_option("long_name", long_name, diag_CS) if (present(units)) call describe_option("units", units, diag_CS) @@ -2517,6 +2685,17 @@ subroutine log_available_diag(used, module_name, field_name, cell_methods_string end subroutine log_available_diag +!> Log the diagnostic chksum to the chksum diag file +subroutine log_chksum_diag(docunit, description, chksum) + integer, intent(in) :: docunit !< Handle of the log file + 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 + flush(docunit) + +end subroutine log_chksum_diag + !> Allocates fields necessary to store diagnostic remapping fields subroutine diag_grid_storage_init(grid_storage, G, diag) type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 1829537bfd..c43f8f5026 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -209,7 +209,7 @@ end subroutine diag_remap_get_axes_info !! Configuration is complete when diag_remap_configure_axes() has been !! successfully called. function diag_remap_axes_configured(remap_cs) - type(diag_remap_ctrl), intent(in) :: remap_cs + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure logical :: diag_remap_axes_configured diag_remap_axes_configured = remap_cs%configured @@ -223,10 +223,10 @@ function diag_remap_axes_configured(remap_cs) !! target grid whenever T/S change. subroutine diag_remap_update(remap_cs, G, GV, h, T, S, eqn_of_state) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diagnostic coordinate control structure - type(ocean_grid_type), pointer :: G !< The ocean's grid type + type(ocean_grid_type), pointer :: G !< The ocean's grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(:, :, :), intent(in) :: h, T, S !< New thickness, T and S - type(EOS_type), pointer, intent(in) :: eqn_of_state !< A pointer to the equation of state + type(EOS_type), pointer :: eqn_of_state !< A pointer to the equation of state ! Local variables real, dimension(remap_cs%nz + 1) :: zInterfaces @@ -264,11 +264,11 @@ subroutine diag_remap_update(remap_cs, G, GV, h, T, S, eqn_of_state) endif if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then - call build_zstar_column(get_zlike_CS(remap_cs%regrid_cs), nz, & + call build_zstar_column(get_zlike_CS(remap_cs%regrid_cs), & G%bathyT(i,j)*GV%m_to_H, sum(h(i,j,:)), & zInterfaces, zScale=GV%m_to_H) elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then - call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), nz, & + call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & GV%m_to_H*G%bathyT(i,j), sum(h(i,j,:)), zInterfaces) elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then call build_rho_column(get_rho_CS(remap_cs%regrid_cs), G%ke, & diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index a61c20cf5a..a6ca5db387 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -28,6 +28,7 @@ module MOM_document integer, parameter :: mLen = 1240 ! Length of interface/message strings +!> A structure that controls where the documentation occurs, its veborsity and formatting. type, public :: doc_type ; private integer :: unitAll = -1 ! The open unit number for docFileBase + .all. integer :: unitShort = -1 ! The open unit number for docFileBase + .short. @@ -60,9 +61,13 @@ module MOM_document ! ---------------------------------------------------------------------- +!> This subroutine handles parameter documentation with no value. subroutine doc_param_none(doc, varname, desc, units) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented ! This subroutine handles parameter documentation with no value. integer :: numspc character(len=mLen) :: mesg @@ -80,14 +85,18 @@ subroutine doc_param_none(doc, varname, desc, units) endif end subroutine doc_param_none +!> This subroutine handles parameter documentation for logicals. subroutine doc_param_logical(doc, varname, desc, units, val, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - logical, intent(in) :: val - logical, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + logical, intent(in) :: val !< The value of this parameter + logical, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for logicals. character(len=mLen) :: mesg logical :: equalsDefault @@ -118,14 +127,18 @@ subroutine doc_param_logical(doc, varname, desc, units, val, default, & endif end subroutine doc_param_logical +!> This subroutine handles parameter documentation for arrays of logicals. subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - logical, intent(in) :: vals(:) - logical, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + logical, intent(in) :: vals(:) !< The array of values to record + logical, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for arrays of logicals. integer :: i character(len=mLen) :: mesg @@ -164,14 +177,18 @@ subroutine doc_param_logical_array(doc, varname, desc, units, vals, default, & endif end subroutine doc_param_logical_array +!> This subroutine handles parameter documentation for integers. subroutine doc_param_int(doc, varname, desc, units, val, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - integer, intent(in) :: val - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + integer, intent(in) :: val !< The value of this parameter + integer, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for integers. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -196,14 +213,18 @@ subroutine doc_param_int(doc, varname, desc, units, val, default, & endif end subroutine doc_param_int +!> This subroutine handles parameter documentation for arrays of integers. subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - integer, intent(in) :: vals(:) - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + integer, intent(in) :: vals(:) !< The array of values to record + integer, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for arrays of integers. integer :: i character(len=mLen) :: mesg @@ -235,12 +256,16 @@ subroutine doc_param_int_array(doc, varname, desc, units, vals, default, & end subroutine doc_param_int_array +!> This subroutine handles parameter documentation for reals. subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - real, intent(in) :: val - real, optional, intent(in) :: default - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + real, intent(in) :: val !< The value of this parameter + real, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for reals. character(len=mLen) :: mesg character(len=doc%commentColumn) :: valstring @@ -265,12 +290,16 @@ subroutine doc_param_real(doc, varname, desc, units, val, default, debuggingPara endif end subroutine doc_param_real +!> This subroutine handles parameter documentation for arrays of reals. subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - real, intent(in) :: vals(:) - real, optional, intent(in) :: default - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + real, intent(in) :: vals(:) !< The array of values to record + real, optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for arrays of reals. integer :: i character(len=mLen) :: mesg @@ -299,14 +328,19 @@ subroutine doc_param_real_array(doc, varname, desc, units, vals, default, debugg end subroutine doc_param_real_array +!> This subroutine handles parameter documentation for character strings. subroutine doc_param_char(doc, varname, desc, units, val, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - character(len=*), intent(in) :: val - character(len=*), optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + character(len=*), intent(in) :: val !< The value of the parameter + character(len=*), & + optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for character strings. character(len=mLen) :: mesg logical :: equalsDefault @@ -330,10 +364,12 @@ subroutine doc_param_char(doc, varname, desc, units, val, default, & end subroutine doc_param_char +!> This subroutine handles documentation for opening a parameter block. subroutine doc_openBlock(doc, blockName, desc) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: blockName - character(len=*), optional, intent(in) :: desc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: blockName !< The name of the parameter block being opened + 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 @@ -353,9 +389,11 @@ subroutine doc_openBlock(doc, blockName, desc) doc%blockPrefix = trim(doc%blockPrefix)//trim(blockName)//'%' end subroutine doc_openBlock +!> This subroutine handles documentation for closing a parameter block. subroutine doc_closeBlock(doc, blockName) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: blockName + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + 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 @@ -377,14 +415,18 @@ subroutine doc_closeBlock(doc, blockName) endif end subroutine doc_closeBlock +!> This subroutine handles parameter documentation for time-type variables. subroutine doc_param_time(doc, varname, desc, units, val, default, & layoutParam, debuggingParam) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varname, desc, units - type(time_type), intent(in) :: val - type(time_type), optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varname !< The name of the parameter being documented + character(len=*), intent(in) :: desc !< A description of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented + type(time_type), intent(in) :: val !< The value of the parameter + type(time_type), optional, intent(in) :: default !< The default value of this parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. ! This subroutine handles parameter documentation for time-type variables. ! ### This needs to be written properly! integer :: numspc @@ -407,14 +449,17 @@ subroutine doc_param_time(doc, varname, desc, units, val, default, & end subroutine doc_param_time +!> This subroutine writes out the message and description to the documetation files. subroutine writeMessageAndDesc(doc, vmesg, desc, valueWasDefault, indent, & layoutParam, debuggingParam) - type(doc_type), intent(in) :: doc - character(len=*), intent(in) :: vmesg, desc - logical, optional, intent(in) :: valueWasDefault - integer, optional, intent(in) :: indent - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(doc_type), intent(in) :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: vmesg !< A message with the parameter name, units, and default value. + character(len=*), intent(in) :: desc !< A description of the parameter being documented + logical, optional, intent(in) :: valueWasDefault !< If true, this parameter has its default value + integer, optional, intent(in) :: indent !< An amount by which to indent this message + logical, optional, intent(in) :: layoutParam !< If present and true, this is a layout parameter. + logical, optional, intent(in) :: debuggingParam !< If present and true, this is a debugging parameter. character(len=mLen) :: mesg integer :: start_ind = 1, end_ind, indnt, tab, len_tab, len_nl logical :: all, short, layout, debug @@ -472,8 +517,9 @@ end subroutine writeMessageAndDesc ! ---------------------------------------------------------------------- +!> This function returns a string with a real formatted like '(G)' function real_string(val) - real, intent(in) :: val + real, intent(in) :: val !< The value being written into a string character(len=32) :: real_string ! This function returns a string with a real formatted like '(G)' integer :: len, ind @@ -523,10 +569,14 @@ function real_string(val) real_string = adjustl(real_string) end function real_string -function real_array_string(vals,sep) - character(len=1320) :: real_array_string - real, intent(in) :: vals(:) - character(len=*), optional :: sep +!> Returns a character string of a comma-separated, compact formatted, reals +!> e.g. "1., 2., 5*3., 5.E2", that give the list of values. +function real_array_string(vals, sep) + character(len=1320) :: real_array_string !< The output string listing vals + real, intent(in) :: vals(:) !< The array of values to record + character(len=*), & + optional, intent(in) :: sep !< The separator between successive values, + !! by default it is ', '. ! Returns a character string of a comma-separated, compact formatted, reals ! e.g. "1., 2., 5*3., 5.E2" ! Local variables @@ -562,9 +612,10 @@ function real_array_string(vals,sep) enddo end function real_array_string +!> This function tests whether a real value is encoded in a string. function testFormattedFloatIsReal(str, val) - character(len=*), intent(in) :: str - real, intent(in) :: val + character(len=*), intent(in) :: str !< The string that match val + real, intent(in) :: val !< The value being tested logical :: testFormattedFloatIsReal ! Local variables real :: scannedVal @@ -577,25 +628,31 @@ function testFormattedFloatIsReal(str, val) endif end function testFormattedFloatIsReal +!> This function returns a string with an integer formatted like '(I)' function int_string(val) - integer, intent(in) :: val + integer, intent(in) :: val !< The value being written into a string character(len=24) :: int_string ! This function returns a string with an integer formatted like '(I)' write(int_string, '(i24)') val int_string = adjustl(int_string) end function int_string +!> This function returns a string with an logical formatted like '(L)' function logical_string(val) - logical, intent(in) :: val + logical, intent(in) :: val !< The value being written into a string character(len=24) :: logical_string ! This function returns a string with an logical formatted like '(L)' write(logical_string, '(l24)') val logical_string = adjustl(logical_string) end function logical_string +!> This function returns a string for formatted parameter assignment function define_string(doc,varName,valString,units) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varName, valString, units + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: valString !< A string containing the value of the parameter + character(len=*), intent(in) :: units !< The units of the parameter being documented character(len=mLen) :: define_string ! This function returns a string for formatted parameter assignment integer :: numSpaces @@ -610,9 +667,12 @@ function define_string(doc,varName,valString,units) if (len_trim(units) > 0) define_string = trim(define_string)//" ["//trim(units)//"]" end function define_string +!> This function returns a string for formatted false logicals function undef_string(doc,varName,units) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varName, units + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: units !< The units of the parameter being documented character(len=mLen) :: undef_string ! This function returns a string for formatted false logicals integer :: numSpaces @@ -630,9 +690,12 @@ end function undef_string ! ---------------------------------------------------------------------- +!> This subroutine handles the module documentation subroutine doc_module(doc, modname, desc) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: modname, desc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: desc !< A description of the module being documented ! This subroutine handles the module documentation character(len=mLen) :: mesg @@ -646,18 +709,26 @@ subroutine doc_module(doc, modname, desc) endif end subroutine doc_module +!> This subroutine handles the subroutine documentation subroutine doc_subroutine(doc, modname, subname, desc) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: modname, subname, desc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: subname !< The name of the subroutine being documented + character(len=*), intent(in) :: desc !< A description of the subroutine being documented ! This subroutine handles the subroutine documentation if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) end subroutine doc_subroutine +!> This subroutine handles the function documentation subroutine doc_function(doc, modname, fnname, desc) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: modname, fnname, desc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: modname !< The name of the module being documented + character(len=*), intent(in) :: fnname !< The name of the function being documented + character(len=*), intent(in) :: desc !< A description of the function being documented ! This subroutine handles the function documentation if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) @@ -667,9 +738,18 @@ end subroutine doc_function ! ---------------------------------------------------------------------- subroutine doc_init(docFileBase, doc, minimal, complete, layout, debugging) - character(len=*), intent(in) :: docFileBase - type(doc_type), pointer :: doc - logical, optional, intent(in) :: minimal, complete, layout, debugging + character(len=*), intent(in) :: docFileBase !< The base file name for this set of parameters, + !! for example MOM_parameter_doc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + logical, optional, intent(in) :: minimal !< If present and true, write out the files (.short) documenting + !! those parameters that do not take on their default values. + logical, optional, intent(in) :: complete !< If present and true, write out the (.all) files documenting all + !! parameters + logical, optional, intent(in) :: layout !< If present and true, write out the (.layout) files documenting + !! the layout parameters + logical, optional, intent(in) :: debugging !< If present and true, write out the (.debugging) files documenting + !! the debugging parameters ! Arguments: docFileBase - The name of the doc file. ! (inout) doc - The doc_type to populate. @@ -685,8 +765,12 @@ subroutine doc_init(docFileBase, doc, minimal, complete, layout, debugging) end subroutine doc_init +!< This subroutine allocates and populates a structure that controls where the +!! documentation occurs and its formatting, and opens up the files controlled +!! by this structure subroutine open_doc_file(doc) - type(doc_type), pointer :: doc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting logical :: opened, new_file integer :: ios @@ -781,6 +865,7 @@ subroutine open_doc_file(doc) end subroutine open_doc_file +! Find an unused unit number, returning >0 if found, and triggering a FATAL error if not. function find_unused_unit_number() ! Find an unused unit number. ! Returns >0 if found. FATAL if not. @@ -794,8 +879,11 @@ function find_unused_unit_number() "doc_init failed to find an unused unit number.") end function find_unused_unit_number +!< This subroutine closes the the files controlled by doc, and sets flags in +!! doc to indicate that parameterization is no longer permitted. subroutine doc_end(doc) - type(doc_type), pointer :: doc + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting type(link_msg), pointer :: this, next if (.not.associated(doc)) return @@ -832,9 +920,13 @@ end subroutine doc_end ! ----------------------------------------------------------------------------- +!> Returns true if documentation has already been written function mesgHasBeenDocumented(doc,varName,mesg) - type(doc_type), pointer :: doc - character(len=*), intent(in) :: varName, mesg + type(doc_type), pointer :: doc !< A pointer to a structure that controls where the + !! documentation occurs and its formatting + character(len=*), intent(in) :: varName !< The name of the parameter being documented + character(len=*), intent(in) :: mesg !< A message with parameter values, defaults, and descriptions + !! to compare with the message that was written previously logical :: mesgHasBeenDocumented ! Returns true if documentation has already been written type(link_msg), pointer :: newLink, this, last diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 10346f2542..4afcf590a2 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -1421,7 +1421,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & integer, optional, intent(in) :: NJPROC !< Processor counts, required with !! static memory. integer, dimension(2), optional, intent(inout) :: min_halo !< If present, this sets the - !! minimum halo size for this domain in the x- and y- + !! minimum halo size for this domain in the i- and j- !! directions, and returns the actual halo size used. character(len=*), optional, intent(in) :: domain_name !< A name for this domain, "MOM" !! if missing. @@ -1444,7 +1444,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! (in,opt) NIGLOBAL, NJGLOBAL - Total domain sizes, required with static memory. ! (in,opt) NIPROC, NJPROC - Processor counts, required with static memory. ! (in,opt) min_halo - If present, this sets the minimum halo size for this -! domain in the x- and y- directions, and returns the +! domain in the i- and j- directions, and returns the ! actual halo size used. ! (in,opt) domain_name - A name for this domain, "MOM" if missing. ! (in,opt) include_name - A name for model's include file, "MOM_memory.h" if missing. @@ -1536,34 +1536,40 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & default=.false.) #ifndef NOT_SET_AFFINITY -!$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & -!$ "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 (ocean_omp_hyper_thread) then -!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & -!$ "Number of cores per node needed for hyper-threading.", & -!$ fail_if_missing=.true., layoutParam=.true.) -!$ endif -!$ call omp_set_num_threads(ocean_nthreads) +!$OMP PARALLEL +!$OMP master +!$ ocean_nthreads = omp_get_num_threads() +!$OMP END MASTER +!$OMP END PARALLEL +!$ if(ocean_nthreads < 2 ) then +!$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & +!$ "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 (ocean_omp_hyper_thread) then +!$ call get_param(param_file, mdl, "OMP_CORES_PER_NODE", omp_cores_per_node, & +!$ "Number of cores per node needed for hyper-threading.", & +!$ fail_if_missing=.true., layoutParam=.true.) +!$ endif +!$ call omp_set_num_threads(ocean_nthreads) +!$ base_cpu = get_cpu_affinity() !$OMP PARALLEL private(adder) -!$ base_cpu = get_cpu_affinity() -!$ if (ocean_omp_hyper_thread) then -!$ if (mod(omp_get_thread_num(),2) == 0) then -!$ adder = omp_get_thread_num()/2 +!$ if (ocean_omp_hyper_thread) then +!$ if (mod(omp_get_thread_num(),2) == 0) then +!$ adder = omp_get_thread_num()/2 +!$ else +!$ adder = omp_cores_per_node + omp_get_thread_num()/2 +!$ endif !$ else -!$ adder = omp_cores_per_node + omp_get_thread_num()/2 +!$ adder = omp_get_thread_num() !$ endif -!$ else -!$ adder = omp_get_thread_num() -!$ endif -!$ call set_cpu_affinity(base_cpu + adder) -!!$ write(6,*) " ocean ", omp_get_num_threads(), get_cpu_affinity(), adder, omp_get_thread_num() +!$ call set_cpu_affinity(base_cpu + adder) +!!$ write(6,*) " ocean ", base_cpu, get_cpu_affinity(), adder, omp_get_thread_num(), omp_get_num_threads() !!$ call flush(6) !$OMP END PARALLEL +!$ endif #endif - call log_param(param_file, mdl, "!SYMMETRIC_MEMORY_", MOM_dom%symmetric, & "If defined, the velocity point data domain includes \n"//& "every face of the thickness points. In other words, \n"//& @@ -1717,7 +1723,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(njproc_nm), layout(2), & - "The number of processors in the x-direction. With \n"//& + "The number of processors in the x-direction. With \n"//& !### FIX THIS COMMENT "STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.",& layoutParam=.true.) call log_param(param_file, mdl, trim(layout_nm), layout, & @@ -1738,7 +1744,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call parse_mask_table(mask_table, MOM_dom%maskmap, dom_name) endif - ! Set up the I/O lay-out, and check that it uses an even multiple of the + ! Set up the I/O layout, and check that it uses an even multiple of the ! number of PEs in each direction. io_layout(:) = (/ 1, 1 /) call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & @@ -1751,8 +1757,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & &"are not allowed in ")') io_layout(1) call MOM_error(FATAL, mesg//trim(IO_layout_nm)) elseif (io_layout(1) > 0) then ; if (modulo(layout(1), io_layout(1)) /= 0) then - write(mesg,'("MOM_domains_init: The x-direction I/O-layout, IO_LAYOUT(1)=",i4, & - &", does not evenly divide the x-direction layout, NIPROC=,",i4,".")') & + write(mesg,'("MOM_domains_init: The i-direction I/O-layout, IO_LAYOUT(1)=",i4, & + &", does not evenly divide the i-direction layout, NIPROC=,",i4,".")') & io_layout(1),layout(1) call MOM_error(FATAL, mesg) endif ; endif @@ -1762,8 +1768,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & &"are not allowed in ")') io_layout(2) call MOM_error(FATAL, mesg//trim(IO_layout_nm)) elseif (io_layout(2) /= 0) then ; if (modulo(layout(2), io_layout(2)) /= 0) then - write(mesg,'("MOM_domains_init: The y-direction I/O-layout, IO_LAYOUT(2)=",i4, & - &", does not evenly divide the y-direction layout, NJPROC=,",i4,".")') & + write(mesg,'("MOM_domains_init: The j-direction I/O-layout, IO_LAYOUT(2)=",i4, & + &", does not evenly divide the j-direction layout, NJPROC=,",i4,".")') & io_layout(2),layout(2) call MOM_error(FATAL, mesg) endif ; endif @@ -1834,12 +1840,23 @@ end subroutine MOM_domains_init !! some properties of the new type to differ from the original one. subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, & domain_name) - type(MOM_domain_type), intent(in) :: MD_in - type(MOM_domain_type), pointer :: MOM_dom - integer, dimension(2), optional, intent(inout) :: min_halo - integer, optional, intent(in) :: halo_size - logical, optional, intent(in) :: symmetric - character(len=*), optional, intent(in) :: domain_name + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain + type(MOM_domain_type), pointer :: MOM_dom !< A pointer to a MOM_domain that will be + !! allocated if it is unassociated, and will have data + !! copied from MD_in + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domian in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. integer :: global_indices(4) logical :: mask_table_exists @@ -1915,12 +1932,21 @@ end subroutine clone_MD_to_MD !! the original one. subroutine clone_MD_to_d2D(MD_in, mpp_domain, min_halo, halo_size, symmetric, & domain_name) - type(MOM_domain_type), intent(in) :: MD_in - type(domain2d), intent(inout) :: mpp_domain - integer, dimension(2), optional, intent(inout) :: min_halo - integer, optional, intent(in) :: halo_size - logical, optional, intent(in) :: symmetric - character(len=*), optional, intent(in) :: domain_name + type(MOM_domain_type), intent(in) :: MD_in !< An existing MOM_domain to be cloned + type(domain2d), intent(inout) :: mpp_domain !< The new mpp_domain to be set up + integer, dimension(2), & + optional, intent(inout) :: min_halo !< If present, this sets the + !! minimum halo size for this domain in the i- and j- + !! directions, and returns the actual halo size used. + integer, optional, intent(in) :: halo_size !< If present, this sets the halo + !! size for the domian in the i- and j-directions. + !! min_halo and halo_size can not both be present. + logical, optional, intent(in) :: symmetric !< If present, this specifies + !! whether the new domain is symmetric, regardless of + !! whether the macro SYMMETRIC_MEMORY_ is defined. + character(len=*), & + optional, intent(in) :: domain_name !< A name for the new domain, "MOM" + !! if missing. integer :: global_indices(4), layout(2), io_layout(2) integer :: X_FLAGS, Y_FLAGS, niglobal, njglobal, nihalo, njhalo @@ -1981,7 +2007,7 @@ subroutine get_domain_extent(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed, & isg, ieg, jsg, jeg, idg_offset, jdg_offset, & symmetric, local_indexing, index_offset) type(MOM_domain_type), & - intent(in) :: Domain + intent(in) :: Domain !< The MOM domain from which to extract information integer, intent(out) :: isc, iec, jsc, jec !< The start & end indices of the computational !! domain. integer, intent(out) :: isd, ied, jsd, jed !< The start & end indices of the data domain. @@ -2042,7 +2068,7 @@ end subroutine get_domain_extent !> Returns the global shape of h-point arrays subroutine get_global_shape(domain, niglobal, njglobal) - type(MOM_domain_type), intent(in) :: domain !< MOM domain + type(MOM_domain_type), intent(in) :: domain !< MOM domain integer, intent(out) :: niglobal !< i-index global size of h-point arrays integer, intent(out) :: njglobal !< j-index global size of h-point arrays diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 8450b055ee..a11646aa2a 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -54,7 +54,6 @@ module MOM_dyn_horgrid dxCu, IdxCu, & ! dxCu is delta x at u points, in m, and IdxCu is 1/dxCu in m-1. dyCu, IdyCu, & ! dyCu is delta y at u points, in m, and IdyCu is 1/dyCu in m-1. dy_Cu, & ! The unblocked lengths of the u-faces of the h-cell in m. - dy_Cu_obc, & ! The unblocked lengths of the u-faces of the h-cell in m for OBC. IareaCu, & ! The masked inverse areas of u-grid cells in m2. areaCu ! The areas of the u-grid cells in m2. @@ -65,7 +64,6 @@ module MOM_dyn_horgrid dxCv, IdxCv, & ! dxCv is delta x at v points, in m, and IdxCv is 1/dxCv in m-1. dyCv, IdyCv, & ! dyCv is delta y at v points, in m, and IdyCv is 1/dyCv in m-1. dx_Cv, & ! The unblocked lengths of the v-faces of the h-cell in m. - dx_Cv_obc, & ! The unblocked lengths of the v-faces of the h-cell in m for OBC. IareaCv, & ! The masked inverse areas of v-grid cells in m2. areaCv ! The areas of the v-grid cells in m2. @@ -204,8 +202,6 @@ subroutine create_dyn_horgrid(G, HI, bathymetry_at_vel) allocate(G%dx_Cv(isd:ied,JsdB:JedB)) ; G%dx_Cv(:,:) = 0.0 allocate(G%dy_Cu(IsdB:IedB,jsd:jed)) ; G%dy_Cu(:,:) = 0.0 - allocate(G%dx_Cv_obc(isd:ied,JsdB:JedB)) ; G%dx_Cv_obc(:,:) = 0.0 - allocate(G%dy_Cu_obc(IsdB:IedB,jsd:jed)) ; G%dy_Cu_obc(:,:) = 0.0 allocate(G%areaCu(IsdB:IedB,jsd:jed)) ; G%areaCu(:,:) = 0.0 allocate(G%areaCv(isd:ied,JsdB:JedB)) ; G%areaCv(:,:) = 0.0 @@ -319,7 +315,6 @@ subroutine destroy_dyn_horgrid(G) deallocate(G%geoLonCv) ; deallocate(G%geoLonBu) deallocate(G%dx_Cv) ; deallocate(G%dy_Cu) - deallocate(G%dx_Cv_obc) ; deallocate(G%dy_Cu_obc) deallocate(G%bathyT) ; deallocate(G%CoriolisBu) deallocate(G%dF_dx) ; deallocate(G%dF_dy) diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 48edffc1f6..e1a85b52c4 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -46,6 +46,7 @@ module MOM_error_handler contains +!> This returns .true. if the current PE is the root PE. function is_root_pe() ! This returns .true. if the current PE is the root PE. logical :: is_root_pe @@ -54,10 +55,12 @@ function is_root_pe() return end function is_root_pe +!> This provides a convenient interface for writing an informative comment. subroutine MOM_mesg(message, verb, all_print) - character(len=*), intent(in) :: message - integer, optional, intent(in) :: verb - logical, optional, intent(in) :: all_print + character(len=*), intent(in) :: message !< A message to write out + integer, optional, intent(in) :: verb !< A level of verbosity for this message + logical, optional, intent(in) :: all_print !< If present and true, any PEs are + !! able to write this message. ! This provides a convenient interface for writing an informative comment. integer :: verb_msg logical :: write_msg @@ -70,10 +73,13 @@ subroutine MOM_mesg(message, verb, all_print) end subroutine MOM_mesg +!> This provides a convenient interface for writing an mpp_error message +!! with run-time filter based on a verbosity. subroutine MOM_error(level, message, all_print) - integer, intent(in) :: level - character(len=*), intent(in) :: message - logical, optional, intent(in) :: all_print + integer, intent(in) :: level !< The verbosity level of this message + character(len=*), intent(in) :: message !< A message to write out + logical, optional, intent(in) :: all_print !< If present and true, any PEs are + !! able to write this message. ! This provides a convenient interface for writing an mpp_error message ! with run-time filter based on a verbosity. logical :: write_msg @@ -93,8 +99,9 @@ subroutine MOM_error(level, message, all_print) end select end subroutine MOM_error +!> This subroutine sets the level of verbosity filtering MOM error messages subroutine MOM_set_verbosity(verb) - integer, intent(in) :: verb + integer, intent(in) :: verb !< A level of verbosity to set character(len=80) :: msg if (verb>0 .and. verb<10) then verbosity=verb @@ -104,13 +111,16 @@ subroutine MOM_set_verbosity(verb) endif end subroutine MOM_set_verbosity +!> This subroutine gets the level of verbosity filtering MOM error messages function MOM_get_verbosity() integer :: MOM_get_verbosity MOM_get_verbosity = verbosity end function MOM_get_verbosity +!> This tests whether the level of verbosity filtering MOM error messages is +!! sufficient to write a message of verbosity level verb function MOM_verbose_enough(verb) - integer, intent(in) :: verb + integer, intent(in) :: verb !< A level of verbosity to test logical :: MOM_verbose_enough MOM_verbose_enough = (verbosity >= verb) end function MOM_verbose_enough @@ -124,8 +134,8 @@ end function callTree_showQuery !> Writes a message about entering a subroutine if call tree reporting is active subroutine callTree_enter(mesg,n) - character(len=*) :: mesg !< Message to write - integer, optional :: n !< An optional integer to write at end of message + character(len=*), intent(in) :: mesg !< Message to write + integer, optional, intent(in) :: n !< An optional integer to write at end of message ! Local variables character(len=8) :: nAsString callTreeIndentLevel = callTreeIndentLevel + 1 @@ -155,8 +165,8 @@ end subroutine callTree_leave !> Writes a message about reaching a milestone if call tree reporting is active subroutine callTree_waypoint(mesg,n) - character(len=*) :: mesg !< Message to write - integer, optional :: n !< An optional integer to write at end of message + character(len=*), intent(in) :: mesg !< Message to write + integer, optional, intent(in) :: n !< An optional integer to write at end of message ! Local variables character(len=8) :: nAsString if (callTreeIndentLevel<0) write(0,*) 'callTree_waypoint: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 436008101f..e22b36e5cd 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -41,7 +41,7 @@ module MOM_file_parser implicit none ; private integer, parameter, public :: MAX_PARAM_FILES = 5 ! Maximum number of parameter files. -integer, parameter :: INPUT_STR_LENGTH = 200 ! Maximum linelength in parameter file. +integer, parameter :: INPUT_STR_LENGTH = 320 ! Maximum linelength in parameter file. integer, parameter :: FILENAME_LENGTH = 200 ! Maximum number of characters in ! file names. @@ -72,66 +72,76 @@ module MOM_file_parser end type parameter_block type, public :: param_file_type ; private - integer :: nfiles = 0 ! The number of open files. - integer :: iounit(MAX_PARAM_FILES) ! The unit number of an open file. - character(len=FILENAME_LENGTH) :: filename(MAX_PARAM_FILES) ! The names of the open files. - logical :: NetCDF_file(MAX_PARAM_FILES)! If true, the input file is in NetCDF. + integer :: nfiles = 0 !< The number of open files. + integer :: iounit(MAX_PARAM_FILES) !< The unit numbers of open files. + character(len=FILENAME_LENGTH) :: filename(MAX_PARAM_FILES) !< The names of the open files. + logical :: NetCDF_file(MAX_PARAM_FILES) !< If true, the input file is in NetCDF. ! This is not yet implemented. - type(file_data_type) :: param_data(MAX_PARAM_FILES) ! Structures that contain - ! the valid data lines from the parameter - ! files, enabling all subsequent reads of - ! parameter data to occur internally. - logical :: report_unused = report_unused_default ! If true, report any - ! parameter lines that are not used in the run. - logical :: unused_params_fatal = unused_params_fatal_default ! If true, kill - ! the run if there are any unused parameters. - 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 :: stdout, stdlog ! The units from stdout() and stdlog(). - character(len=240) :: doc_file ! A file where all run-time parameters, their - ! settings and defaults are documented. - logical :: complete_doc = complete_doc_default ! If true, document all - ! run-time parameters. - logical :: minimal_doc = minimal_doc_default ! If true, document only those - ! run-time parameters that differ from defaults. - type(doc_type), pointer :: doc => NULL() ! A structure that contains information - ! related to parameter documentation. - type(link_parameter), pointer :: chain => NULL() ! Facilitates linked list - type(parameter_block), pointer :: blockName => NULL() ! Name of active parameter block + type(file_data_type) :: param_data(MAX_PARAM_FILES) !< Structures that contain + !! the valid data lines from the parameter + !! files, enabling all subsequent reads of + !! parameter data to occur internally. + logical :: report_unused = report_unused_default !< If true, report any + !! parameter lines that are not used in the run. + logical :: unused_params_fatal = unused_params_fatal_default !< If true, kill + !! the run if there are any unused parameters. + 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 :: stdout, stdlog !< The units from stdout() and stdlog(). + character(len=240) :: doc_file !< A file where all run-time parameters, their + !! settings and defaults are documented. + logical :: complete_doc = complete_doc_default !< If true, document all + !! run-time parameters. + logical :: minimal_doc = minimal_doc_default !< If true, document only those + !! run-time parameters that differ from defaults. + type(doc_type), pointer :: doc => NULL() !< A structure that contains information + !! related to parameter documentation. + type(link_parameter), pointer :: chain => NULL() !< Facilitates linked list + type(parameter_block), pointer :: blockName => NULL() !< Name of active parameter block end type param_file_type public read_param, open_param_file, close_param_file, log_param, log_version public doc_param, get_param public clearParameterBlock, openParameterBlock, closeParameterBlock +!> An overloaded interface to read various types of parameters interface read_param module procedure read_param_int, read_param_real, read_param_logical, & read_param_char, read_param_char_array, read_param_time, & read_param_int_array, read_param_real_array end interface +!> An overloaded interface to log the values of various types of parameters interface log_param module procedure log_param_int, log_param_real, log_param_logical, & log_param_char, log_param_time, & log_param_int_array, log_param_real_array end interface +!> An overloaded interface to log the values of various types of parameters interface get_param module procedure get_param_int, get_param_real, get_param_logical, & get_param_char, get_param_char_array, get_param_time, & get_param_int_array, get_param_real_array end interface + +!> An overloaded interface to log version information about modules interface log_version module procedure log_version_cs, log_version_plain end interface contains +!> Make the contents of a parameter input file availalble in a param_file_type subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) - character(len=*), intent(in) :: filename - type(param_file_type), intent(inout) :: CS - logical, optional, intent(in) :: checkable - character(len=*), optional, intent(in) :: component - character(len=*), optional, intent(in) :: doc_file_dir + character(len=*), intent(in) :: filename !< An input file name, optionally with the full path + type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + logical, optional, intent(in) :: checkable !< If this is false, it disables checks of this + !! file for unused parameters. The default is True. + character(len=*), optional, intent(in) :: component !< If present, this component name is used + !! to generate parameter documentation file names; the default is"MOM" + character(len=*), optional, intent(in) :: doc_file_dir !< An optional directory in which to write out + !! the documentation files. The default is effectively './'. logical :: file_exists, unit_in_use, Netcdf_file, may_check integer :: ios, iounit, strlen, i @@ -244,17 +254,23 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) end subroutine open_param_file +!> Close any open input files and deallocate memory associated with this param_file_type. +!! To use this type again, open_param_file would have to be called again. subroutine close_param_file(CS, quiet_close, component) - type(param_file_type), intent(inout) :: CS - logical, optional, intent(in) :: quiet_close - character(len=*), optional, intent(in) :: component + type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + logical, optional, intent(in) :: quiet_close !< if present and true, do not do any + !! logging with this call. + character(len=*), optional, intent(in) :: component !< If present, this component name is used + !! to generate parameter documentation file names ! Arguments: CS - the param_file_type to close ! (in,opt) quiet_close - if present and true, do not do any logging with this ! call. -! This include declares and sets the variable "version". -#include "version_variable.h" + character(len=128) :: docfile_default character(len=40) :: mdl ! This module's name. +! This include declares and sets the variable "version". +#include "version_variable.h" integer :: i, n, num_unused if (present(quiet_close)) then ; if (quiet_close) then @@ -276,18 +292,17 @@ subroutine close_param_file(CS, quiet_close, component) ! Log the parameters for the parser. mdl = "MOM_file_parser" call log_version(CS, mdl, version, "") - call log_param(CS, mdl, "SEND_LOG_TO_STDOUT", & - CS%log_to_stdout, & + call log_param(CS, mdl, "SEND_LOG_TO_STDOUT", CS%log_to_stdout, & "If true, all log messages are also sent to stdout.", & default=log_to_stdout_default) - call log_param(CS, mdl, "REPORT_UNUSED_PARAMS", & - CS%report_unused, & + call log_param(CS, mdl, "REPORT_UNUSED_PARAMS", CS%report_unused, & "If true, report any parameter lines that are not used \n"//& - "in the run.", default=report_unused_default) - call log_param(CS, mdl, "FATAL_UNUSED_PARAMS", & - CS%unused_params_fatal, & + "in the run.", default=report_unused_default, & + debuggingParam=.true.) + call log_param(CS, mdl, "FATAL_UNUSED_PARAMS", CS%unused_params_fatal, & "If true, kill the run if there are any unused \n"//& - "parameters.", default=unused_params_fatal_default) + "parameters.", default=unused_params_fatal_default, & + debuggingParam=.true.) docfile_default = "MOM_parameter_doc" if (present(component)) docfile_default = trim(component)//"_parameter_doc" call log_param(CS, mdl, "DOCUMENT_FILE", CS%doc_file, & @@ -295,13 +310,11 @@ subroutine close_param_file(CS, quiet_close, component) "settings, units and defaults are documented. Blank will\n"//& "disable all parameter documentation.", default=docfile_default) if (len_trim(CS%doc_file) > 0) then - call log_param(CS, mdl, "COMPLETE_DOCUMENTATION", & - CS%complete_doc, & + call log_param(CS, mdl, "COMPLETE_DOCUMENTATION", CS%complete_doc, & "If true, all run-time parameters are\n"//& "documented in "//trim(CS%doc_file)//& ".all .", default=complete_doc_default) - call log_param(CS, mdl, "MINIMAL_DOCUMENTATION", & - CS%minimal_doc, & + call log_param(CS, mdl, "MINIMAL_DOCUMENTATION", CS%minimal_doc, & "If true, non-default run-time parameters are\n"//& "documented in "//trim(CS%doc_file)//& ".short .", default=minimal_doc_default) @@ -340,10 +353,13 @@ subroutine close_param_file(CS, quiet_close, component) end subroutine close_param_file +!> Read the contents of a parameter input file, and store the contents in a +!! file_data_type after removing comments and simplifying white space subroutine populate_param_data(iounit, filename, param_data) - integer, intent(in) :: iounit - character(len=*), intent(in) :: filename - type(file_data_type), intent(inout) :: param_data + integer, intent(in) :: iounit !< The IO unit number that is open for filename + character(len=*), intent(in) :: filename !< An input file name, optionally with the full path + type(file_data_type), intent(inout) :: param_data !< A list of the input lines that set parameters + !! after comments have been stripped out. character(len=INPUT_STR_LENGTH) :: line integer :: num_lines @@ -435,8 +451,10 @@ subroutine populate_param_data(iounit, filename, param_data) end subroutine populate_param_data + +!> Return True if a /* appears on this line without a closing */ function openMultiLineComment(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process logical :: openMultiLineComment ! True if a /* appears on this line without a closing */ integer :: icom, last @@ -450,38 +468,43 @@ function openMultiLineComment(string) icom = index(string(last:), "*/") ; if (icom > 0) openMultiLineComment=.false. end function openMultiLineComment +!> Return True if a */ appears on this line function closeMultiLineComment(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process logical :: closeMultiLineComment ! True if a */ appears on this line closeMultiLineComment = .false. if (index(string, "*/")>0) closeMultiLineComment=.true. end function closeMultiLineComment +!> Find position of last character before any comments, As marked by "!", "//", or "/*" +!! following F90, C++, or C syntax function lastNonCommentIndex(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process integer :: lastNonCommentIndex ! Find position of last character before any comments ! This s/r is the only place where a comment needs to be defined integer :: icom, last last = len_trim(string) icom = index(string(:last), "!") ; if (icom > 0) last = icom-1 ! F90 style - icom = index(string(:last), "//") ; if (icom > 0) last = icom-1 ! C+ style + icom = index(string(:last), "//") ; if (icom > 0) last = icom-1 ! C++ style icom = index(string(:last), "/*") ; if (icom > 0) last = icom-1 ! C style lastNonCommentIndex = last end function lastNonCommentIndex +!> Find position of last non-blank character before any comments function lastNonCommentNonBlank(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process integer :: lastNonCommentNonBlank ! Find position of last non-blank character before any comments lastNonCommentNonBlank = len_trim(string(:lastNonCommentIndex(string))) ! Ignore remaining trailing blanks end function lastNonCommentNonBlank +!> Returns a string with tabs replaced by a blank function replaceTabs(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process character(len=len(string)) :: replaceTabs -! Returns string with tabs replaced by a ablank +! Returns string with tabs replaced by a blank integer :: i do i=1, len(string) if (string(i:i)==achar(9)) then @@ -492,8 +515,9 @@ function replaceTabs(string) enddo end function replaceTabs +!> Trims comments and leading blanks from string function removeComments(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process character(len=len(string)) :: removeComments ! Trims comments and leading blanks from string integer :: last @@ -502,8 +526,10 @@ function removeComments(string) removeComments(:last)=adjustl(string(:last)) ! Copy only the non-comment part of string end function removeComments +!> Constructs a string with all repeated whitespace replaced with single blanks +!! and insert white space where it helps delineate tokens (e.g. around =) function simplifyWhiteSpace(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< A string to modify to simpify white space character(len=len(string)+16) :: simplifyWhiteSpace ! Constructs a string with all repeated whitespace replaced with single blanks ! and insert white space where it helps delineate tokens (e.g. around =) @@ -554,11 +580,15 @@ function simplifyWhiteSpace(string) endif end function simplifyWhiteSpace +!> This subroutine reads the value of an integer model parameter from a parameter file. subroutine read_param_int(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - integer, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing + 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) :: varname !< The case-sensitive name of the parameter to read + integer, intent(inout) :: value !< The value of the parameter that may be + !! read from 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 ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -586,11 +616,15 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_int +!> This subroutine reads the values of an array of integer model parameters from a parameter file. subroutine read_param_int_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - integer, intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing + 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) :: varname !< The case-sensitive name of the parameter to read + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from 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 ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -619,11 +653,15 @@ subroutine read_param_int_array(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_int_array +!> This subroutine reads the value of a real model parameter from a parameter file. subroutine read_param_real(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - real, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing + 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) :: varname !< The case-sensitive name of the parameter to read + real, intent(inout) :: value !< The value of the parameter that may be + !! read from 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 ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -651,11 +689,15 @@ subroutine read_param_real(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_real +!> This subroutine reads the values of an array of real model parameters from a parameter file. subroutine read_param_real_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - real, intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing + 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) :: varname !< The case-sensitive name of the parameter to read + real, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from 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 ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -684,11 +726,15 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_real_array +!> This subroutine reads the value of a character string model parameter from a parameter file. subroutine read_param_char(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing + 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) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(inout) :: value !< The value of the parameter that may be + !! read from 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 ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -707,11 +753,15 @@ subroutine read_param_char(CS, varname, value, fail_if_missing) end subroutine read_param_char +!> This subroutine reads the values of an array of character string model parameters from a parameter file. subroutine read_param_char_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing + 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) :: varname !< The case-sensitive name of the parameter to read + character(len=*), dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from 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 ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -744,11 +794,15 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) end subroutine read_param_char_array +!> This subroutine reads the value of a logical model parameter from a parameter file. subroutine read_param_logical(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - logical, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing + 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) :: varname !< The case-sensitive name of the parameter to read + logical, intent(inout) :: value !< The value of the parameter that may be + !! read from 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 ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -766,14 +820,19 @@ subroutine read_param_logical(CS, varname, value, fail_if_missing) endif ; endif end subroutine read_param_logical - +!> This subroutine reads the value of a time_type model parameter from a parameter file. subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - type(time_type), intent(inout) :: value - real, optional, intent(in) :: timeunit - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(out) :: date_format + 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) :: varname !< The case-sensitive name of the parameter to read + type(time_type), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for real-number input. + 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(out) :: date_format !< If present, this indicates whether this + !! parameter was read in a date format, so that it can + !! later be logged in the same format. ! This subroutine determines the value of an time-type model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -837,8 +896,9 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f trim(varname)// ' parsing "'//trim(value_string(1))//'"') 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 + character(len=*) :: val_str !< The character string to work on character(len=INPUT_STR_LENGTH) :: strip_quotes ! Local variables integer :: i @@ -857,12 +917,18 @@ 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 +!! 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) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - logical, intent(out) :: found, defined - character(len=*), intent(out) :: value_string(:) - logical, optional, intent(in) :: paramIsLogical + 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) :: varname !< The case-sensitive name of the parameter to read + logical, intent(out) :: found !< If true, this parameter has been found in CS + logical, intent(out) :: defined !< If true, this parameter is set (or true) in the CS + character(len=*), intent(out) :: value_string(:) !< A string that encodes the new value + logical, optional, intent(in) :: paramIsLogical !< If true, this is a logical parameter + !! that can be simply defined without parsing a value_string. character(len=INPUT_STR_LENGTH) :: val_str, lname, origLine character(len=INPUT_STR_LENGTH) :: line, continuationBuffer, blockName @@ -888,7 +954,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! return variables indicating whether this variable is defined and the string ! that contains the value of this variable. found = .false. - oval = 0; ival = 0; + oval = 0; ival = 0 max_vals = SIZE(value_string) do is=1,max_vals ; value_string(is) = " " ; enddo @@ -1173,15 +1239,17 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL end subroutine get_variable_line -subroutine flag_line_as_read(line_used,count) - logical, dimension(:), pointer :: line_used - integer, intent(in) :: count +!> 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 line_used(count) = .true. end subroutine flag_line_as_read +!> Returns true if an override warning has been issued for the variable varName function overrideWarningHasBeenIssued(chain, varName) type(link_parameter), pointer :: chain - character(len=*), intent(in) :: varName + character(len=*), intent(in) :: varName !< The name of the variable being queried for warnings logical :: overrideWarningHasBeenIssued ! Returns true if an override warning has been issued for the variable varName type(link_parameter), pointer :: newLink, this @@ -1237,16 +1305,22 @@ subroutine log_version_plain(modulename, version) end subroutine log_version_plain +!> Log the name and value of an integer model parameter in documentation files. subroutine log_param_int(CS, modulename, varname, value, desc, units, & default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: 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 module using this parameter + character(len=*), intent(in) :: varname !< The name of the parameter to log + integer, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of an integer parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1264,16 +1338,22 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & end subroutine log_param_int +!> Log the name and values of an array of integer model parameter in documentation files. subroutine log_param_int_array(CS, modulename, varname, value, desc, & units, default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(in) :: value(:) - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: 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 module using this parameter + character(len=*), intent(in) :: varname !< The name of the parameter to log + integer, dimension(:), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of an integer parameter to a log file, ! along with its name and the module it came from. character(len=1320) :: mesg @@ -1292,15 +1372,20 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & end subroutine log_param_int_array +!> Log the name and value of a real model parameter in documentation files. subroutine log_param_real(CS, modulename, varname, value, desc, units, & default, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: varname !< The name of the parameter to log + real, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1319,14 +1404,18 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & end subroutine log_param_real +!> Log the name and values of an array of real model parameter in documentation files. subroutine log_param_real_array(CS, modulename, varname, value, desc, & units, default) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(in) :: value(:) - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default + 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 + character(len=*), intent(in) :: varname !< The name of the parameter to log + real, dimension(:), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. character(len=1320) :: mesg @@ -1348,16 +1437,22 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & end subroutine log_param_real_array +!> Log the name and value of a logical model parameter in documentation files. subroutine log_param_logical(CS, modulename, varname, value, desc, & units, default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - logical, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - logical, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: varname !< The name of the parameter to log + logical, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a logical parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1379,16 +1474,22 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & end subroutine log_param_logical +!> Log the name and value of a character string model parameter in documentation files. subroutine log_param_char(CS, modulename, varname, value, desc, units, & default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: varname !< The name of the parameter to log + character(len=*), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a character string parameter to a log ! file, along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1411,16 +1512,23 @@ end subroutine log_param_char !! along with its name and the module it came from. subroutine log_param_time(CS, modulename, varname, value, desc, units, & default, timeunit, layoutParam, debuggingParam, log_date) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - type(time_type), intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - type(time_type), optional, intent(in) :: default - real, optional, intent(in) :: timeunit + 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 + character(len=*), intent(in) :: varname !< The name of the parameter to log + type(time_type), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for + !! real-number output. logical, optional, intent(in) :: log_date !< If true, log the time_type in date format. - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + !! If missing the default is false. + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file real :: real_time, real_default logical :: use_timeunit, date_format @@ -1519,19 +1627,34 @@ function convert_date_to_string(date) result(date_string) end function convert_date_to_string +!> This subroutine reads the value of an integer model parameter from a parameter file +!! 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) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1552,19 +1675,34 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & end subroutine get_param_int +!> This subroutine reads the values of an array of integer model parameters from a parameter file +!! 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) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be reset + !! from the parameter file + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1585,16 +1723,32 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & end subroutine get_param_int_array +!> This subroutine reads the value of a real model parameter from a parameter file +!! 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) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log + default, fail_if_missing, do_not_read, do_not_log, & + static_value, 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 + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1610,23 +1764,35 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & if (do_log) then call log_param_real(CS, modulename, varname, value, desc, units, & - default) + default, debuggingParam) endif end subroutine get_param_real +!> This subroutine reads the values of an array of real model parameters from a parameter file +!! 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, static_value) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + 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 + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical :: do_read, do_log do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1645,19 +1811,34 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & end subroutine get_param_real_array +!> This subroutine reads the value of a character string model parameter from a parameter file +!! 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) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1678,16 +1859,29 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & 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) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1718,19 +1912,34 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & end subroutine get_param_char_array +!> This subroutine reads the value of a logical model parameter from a parameter file +!! 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) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - logical, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - logical, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1751,22 +1960,39 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & end subroutine get_param_logical +!> This subroutine reads the value of a time-type model parameter from a parameter file +!! 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, & log_as_date) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - type(time_type), intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - type(time_type), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - real, optional, intent(in) :: timeunit - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam - logical, optional, intent(in) :: 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 + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + type(time_type), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter 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 + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for + !! real-number input to be translated to a time. + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: log_as_date !< If true, log the time_type in date + !! format. The default is false. ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log, date_format, log_date @@ -1792,8 +2018,10 @@ end subroutine get_param_time ! ----------------------------------------------------------------------------- +!> Resets the parameter block name to blank subroutine clearParameterBlock(CS) - type(param_file_type), intent(in) :: CS + 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 ! Resets the parameter block name to blank type(parameter_block), pointer :: block if (associated(CS%blockName)) then @@ -1805,10 +2033,12 @@ subroutine clearParameterBlock(CS) endif end subroutine clearParameterBlock +!> Tags blockName onto the end of the active parameter block name subroutine openParameterBlock(CS,blockName,desc) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: blockName - character(len=*), optional, intent(in) :: desc + 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) :: blockName !< The name of a parameter block being added + character(len=*), optional, intent(in) :: desc !< A description of the parameter block being added ! Tags blockName onto the end of the active parameter block name type(parameter_block), pointer :: block if (associated(CS%blockName)) then @@ -1821,8 +2051,10 @@ subroutine openParameterBlock(CS,blockName,desc) endif end subroutine openParameterBlock +!> Remove the lowest level of recursion from the active block name subroutine closeParameterBlock(CS) - type(param_file_type), intent(in) :: CS + 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 ! Remove the lowest level of recursion from the active block name type(parameter_block), pointer :: block @@ -1839,8 +2071,10 @@ subroutine closeParameterBlock(CS) block%name = popBlockLevel(block%name) end subroutine closeParameterBlock +!> Extends block name (deeper level of parameter block) function pushBlockLevel(oldblockName,newBlockName) - character(len=*), intent(in) :: oldBlockName, newBlockName + character(len=*), intent(in) :: oldBlockName !< A sequence of hierarchical parameter block names + character(len=*), intent(in) :: newBlockName !< A new block name to add to the end of the sequence character(len=len(oldBlockName)+40) :: pushBlockLevel ! Extends block name (deeper level of parameter block) if (len_trim(oldBlockName)>0) then @@ -1850,8 +2084,9 @@ function pushBlockLevel(oldblockName,newBlockName) endif end function pushBlockLevel +!> Truncates block name (shallower level of parameter block) function popBlockLevel(oldblockName) - character(len=*), intent(in) :: oldBlockName + character(len=*), intent(in) :: oldBlockName !< A sequence of hierarchical parameter block names character(len=len(oldBlockName)+40) :: popBlockLevel ! Truncates block name (shallower level of parameter block) integer :: i diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index 2ee3e93bbd..de75e9713b 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -30,7 +30,7 @@ module MOM_get_input !> Get the names of the I/O directories and initialization file. !! Also calls the subroutine that opens run-time parameter files. -subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename) +subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, ensemble_num) type(param_file_type), optional, intent(out) :: param_file !< A structure to parse for run-time parameters. type(directories), optional, intent(out) :: dirs !< Container for paths and parameter file names. logical, optional, intent(in) :: check_params !< If present and False will stop error checking for @@ -38,6 +38,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename) character(len=*), optional, intent(in) :: default_input_filename !< If present, is the value assumed for !! input_filename if input_filename is not listed !! in the namelist MOM_input_nml. + integer, optional, intent(in) :: ensemble_num !< The ensemble id of the current member ! Local variables integer, parameter :: npf = 5 ! Maximum number of parameter files character(len=240) :: & @@ -77,10 +78,17 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename) ! Store parameters in container if (present(dirs)) then - dirs%output_directory = slasher(ensembler(output_directory)) - dirs%restart_output_dir = slasher(ensembler(restart_output_dir)) - dirs%restart_input_dir = slasher(ensembler(restart_input_dir)) - dirs%input_filename = ensembler(input_filename) + if (present(ensemble_num)) then + dirs%output_directory = slasher(ensembler(output_directory,ensemble_num)) + dirs%restart_output_dir = slasher(ensembler(restart_output_dir,ensemble_num)) + dirs%restart_input_dir = slasher(ensembler(restart_input_dir,ensemble_num)) + dirs%input_filename = ensembler(input_filename,ensemble_num) + else + dirs%output_directory = slasher(ensembler(output_directory)) + dirs%restart_output_dir = slasher(ensembler(restart_output_dir)) + dirs%restart_input_dir = slasher(ensembler(restart_input_dir)) + dirs%input_filename = ensembler(input_filename) + endif endif ! Open run-time parameter file(s) @@ -89,8 +97,13 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename) valid_param_files = 0 do io = 1, npf if (len_trim(trim(parameter_filename(io))) > 0) then - call open_param_file(ensembler(parameter_filename(io)), param_file, & - check_params, doc_file_dir=output_dir) + if (present(ensemble_num)) then + call open_param_file(ensembler(parameter_filename(io),ensemble_num), param_file, & + check_params, doc_file_dir=output_dir) + else + call open_param_file(ensembler(parameter_filename(io)), param_file, & + check_params, doc_file_dir=output_dir) + endif valid_param_files = valid_param_files + 1 endif enddo diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index 4326693957..5a626dd934 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -118,9 +118,9 @@ end subroutine HIT_assign !! The non-symmetric memory mode will then also work, albeit with a different (less efficient) communication pattern. !! !! Using the hor_index_type HI: -!! - declaration of h-point data is of the form `h(HI%%isd:HI%%ied,HI%%jsd:HI%%jed)`; -!! - declaration of q-point data is of the form `q(HI%%IsdB:HI%%IedB,HI%%JsdB:HI%%JedB)`; -!! - declaration of u-point data is of the form `u(HI%%IsdB:HI%%IedB,HI%%jsd:HI%%jed)`; +!! - declaration of h-point data is of the form `h(HI%%isd:HI%%ied,HI%%jsd:HI%%jed)` +!! - declaration of q-point data is of the form `q(HI%%IsdB:HI%%IedB,HI%%JsdB:HI%%JedB)` +!! - declaration of u-point data is of the form `u(HI%%IsdB:HI%%IedB,HI%%jsd:HI%%jed)` !! - declaration of v-point data is of the form `v(HI%%isd:HI%%ied,HI%%JsdB:HI%%JedB)`. !! !! For more detail explanation of horizontal indexing see \ref Horizontal_indexing. diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index d499c3bb53..d4f8dbff57 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -91,6 +91,11 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) endif end subroutine myStats + +!> Use ICE-9 algorithm to populate points (fill=1) with +!! valid data (good=1). If no information is available, +!! Then 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,keep_bug,debug) ! !# Use ICE-9 algorithm to populate points (fill=1) with @@ -105,19 +110,29 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug ! use MOM_coms, only : sum_across_PEs - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: aout - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: good !< Valid data mask for incoming array - !! (1==good data; 0==missing data). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: fill !< Same shape array of points which need - !! filling (1==please fill;0==leave - !! it alone). - real, dimension(SZI_(G),SZJ_(G)), optional, & - intent(in) :: prev !< First guess where isolated holes exist. - logical, intent(in), optional :: smooth - integer, intent(in), optional :: num_pass - real, intent(in), optional :: relc,crit - logical, intent(in), optional :: keep_bug, debug + 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 + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: good !< Valid data mask for incoming array + !! (1==good data; 0==missing data). + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: fill !< Same shape array of points which need + !! filling (1==please fill;0==leave + !! it alone). + 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 smoothing passes to the interpolated data + integer, optional, intent(in) :: num_pass !< The maximum number of smoothing passes + !! to apply. + real, optional, intent(in) :: relc !< A nondimensional relaxation coefficient for + !! the smoothing passes. + real, optional, intent(in) :: crit !< A minimal value for changes in the array + !! at which point the smoothing is stopped. + logical, optional, intent(in) :: keep_bug !< Use an algorithm with a bug that dates + !! to the "sienna" code release. + logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. real, dimension(SZI_(G),SZJ_(G)) :: b,r @@ -132,14 +147,14 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug real, parameter :: relc_default = 0.25, crit_default = 1.e-3 integer :: npass - integer :: is, ie, js, je, nz + integer :: is, ie, js, je real :: relax_coeff, acrit, ares logical :: debug_it debug_it=.false. if (PRESENT(debug)) debug_it=debug - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec npass = num_pass_default if (PRESENT(num_pass)) npass = num_pass @@ -176,15 +191,15 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug do j=js,je i_loop: do i=is,ie - if (good_(i,j) .eq. 1.0 .or. fill(i,j) .eq. 0.) cycle i_loop + if (good_(i,j) == 1.0 .or. fill(i,j) == 0.) cycle i_loop ge=good_(i+1,j);gw=good_(i-1,j) gn=good_(i,j+1);gs=good_(i,j-1) east=0.0;west=0.0;north=0.0;south=0.0 - if (ge.eq.1.0) east=aout(i+1,j)*ge - if (gw.eq.1.0) west=aout(i-1,j)*gw - if (gn.eq.1.0) north=aout(i,j+1)*gn - if (gs.eq.1.0) south=aout(i,j-1)*gs + if (ge == 1.0) east=aout(i+1,j)*ge + if (gw == 1.0) west=aout(i-1,j)*gw + if (gn == 1.0) north=aout(i,j+1)*gn + if (gs == 1.0) south=aout(i,j-1)*gs ngood = ge+gw+gn+gs if (ngood > 0.) then @@ -204,13 +219,13 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug if (nfill == nfill_prev .and. PRESENT(prev)) then do j=js,je do i=is,ie - if (fill_pts(i,j).eq.1.0) then + if (fill_pts(i,j) == 1.0) then aout(i,j)=prev(i,j) fill_pts(i,j)=0.0 endif enddo enddo - else if (nfill .eq. nfill_prev) then + elseif (nfill == nfill_prev) then print *,& 'Unable to fill missing points using either data at the same vertical level from a connected basin'//& 'or using a point from a previous vertical level. Make sure that the original data has some valid'//& @@ -221,17 +236,20 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug nfill = sum(fill_pts(is:ie,js:je)) call sum_across_PEs(nfill) - end do + enddo if (do_smooth) then do k=1,npass call pass_var(aout,G%Domain) do j=js,je do i=is,ie - if (fill(i,j) .eq. 1) then - east=max(good(i+1,j),fill(i+1,j));west=max(good(i-1,j),fill(i-1,j)) - north=max(good(i,j+1),fill(i,j+1));south=max(good(i,j-1),fill(i,j-1)) - r(i,j) = relax_coeff*(south*aout(i,j-1)+north*aout(i,j+1)+west*aout(i-1,j)+east*aout(i+1,j) - (south+north+west+east)*aout(i,j)) + if (fill(i,j) == 1) then + east=max(good(i+1,j),fill(i+1,j)) ; west=max(good(i-1,j),fill(i-1,j)) + north=max(good(i,j+1),fill(i,j+1)) ; south=max(good(i,j-1),fill(i,j-1)) + !### Appropriate parentheses should be added here, but they will change answers. + r(i,j) = relax_coeff*(south*aout(i,j-1)+north*aout(i,j+1) + & + west*aout(i-1,j)+east*aout(i+1,j) - & + (south+north+west+east)*aout(i,j)) else r(i,j) = 0. endif @@ -246,7 +264,7 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug do j=js,je do i=is,ie - if (good_(i,j).eq.0.0 .and. fill_pts(i,j) .eq. 1.0) then + if (good_(i,j) == 0.0 .and. fill_pts(i,j) == 1.0) then print *,'in fill_miss, fill, good,i,j= ',fill_pts(i,j),good_(i,j),i,j call MOM_error(FATAL,"MOM_initialize: "// & "fill is true and good is false after fill_miss, how did this happen? ") @@ -273,9 +291,11 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, !! local model grid and native vertical levels. real, allocatable, dimension(:) :: z_in !< Cell grid values for input data. real, allocatable, dimension(:) :: z_edges_in !< Cell grid edge values for input data. - real, intent(out) :: missing_value - logical, intent(in) :: reentrant_x, tripolar_n - logical, intent(in), optional :: homogenize + real, intent(out) :: missing_value !< The missing value in the returned array. + 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, dimension(:,:), allocatable :: tr_in,tr_inp !< A 2-d array for holding input data on !! native horizontal grid and extended grid @@ -298,7 +318,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, 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 :: ni, nj, nz ! global grid size integer :: id_clock_read character(len=12) :: dim_name(4) logical :: debug=.false. @@ -309,16 +328,16 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, real, dimension(SZI_(G),SZJ_(G)) :: good2,fill2 real, dimension(SZI_(G),SZJ_(G)) :: nlevs - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) - if (ALLOCATED(tr_z)) deallocate(tr_z) - if (ALLOCATED(mask_z)) deallocate(mask_z) - if (ALLOCATED(z_edges_in)) deallocate(z_edges_in) + if (allocated(tr_z)) deallocate(tr_z) + if (allocated(mask_z)) deallocate(mask_z) + if (allocated(z_edges_in)) deallocate(z_edges_in) PI_180=atan(1.0)/45. @@ -329,40 +348,40 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, rcode = NF90_OPEN(filename, NF90_NOWRITE, ncid) - if (rcode .ne. 0) call MOM_error(FATAL,"error opening file "//trim(filename)//& + if (rcode /= 0) call MOM_error(FATAL,"error opening file "//trim(filename)//& " in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, varnam, varid) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(varnam)//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(varnam)//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndims, dimids=dims) - if (rcode .ne. 0) call MOM_error(FATAL,'error inquiring dimensions hinterp_extrap') + if (rcode /= 0) call MOM_error(FATAL,'error inquiring dimensions hinterp_extrap') if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(varnam)//" in file "// & trim(filename)//" has too few dimensions.") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(2), dim_name(2), len=jd) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(2), dim_id(2)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(3), dim_name(3), len=kd) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(3), dim_id(3)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& " in file "//trim(filename)//" in hinterp_extrap") missing_value=0.0 rcode = NF90_GET_ATT(ncid, varid, "_FillValue", missing_value) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding missing value for "//& + if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//& trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") if (allocated(lon_in)) deallocate(lon_in) @@ -378,15 +397,15 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, start = 1; count = 1; count(1) = id rcode = NF90_GET_VAR(ncid, dim_id(1), lon_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & trim(varnam)//",dim_name "//trim(dim_name(1))//" in file "// trim(filename)//" in hinterp_extrap") start = 1; count = 1; count(1) = jd rcode = NF90_GET_VAR(ncid, dim_id(2), lat_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & trim(varnam)//",dim_name "//trim(dim_name(2))//" in file "// trim(filename)//" in hinterp_extrap") start = 1; count = 1; count(1) = kd rcode = NF90_GET_VAR(ncid, dim_id(3), z_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & trim(varnam//",dim_name "//trim(dim_name(3)))//" in file "// trim(filename)//" in hinterp_extrap") call cpu_clock_end(id_clock_read) @@ -451,14 +470,14 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (is_root_pe()) then start = 1; start(3) = k; count = 1; count(1) = id; count(2) = jd rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& "error reading level "//trim(laynum)//" of variable "//& trim(varnam)//" in file "// trim(filename)) if (add_np) then last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) .gt. abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then pole = pole+last_row(i) npole = npole+1.0 endif @@ -478,13 +497,13 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call mpp_sync() call mpp_broadcast(tr_inp,id*jdp,root_PE()) - call mpp_sync_self () + call mpp_sync_self() mask_in=0.0 do j=1,jdp do i=1,id - if (abs(tr_inp(i,j)-missing_value) .gt. abs(roundoff*missing_value)) then + 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) * conversion else @@ -513,7 +532,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, mask_out=1.0 do j=js,je do i=is,ie - if (abs(tr_out(i,j)-missing_value) .lt. abs(roundoff*missing_value)) mask_out(i,j)=0. + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0. enddo enddo @@ -522,14 +541,14 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, nPoints = 0 ; varAvg = 0. do j=js,je do i=is,ie - if (mask_out(i,j) .lt. 1.0) then + 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) .and. mask_out(i,j) .lt. 1.0) fill(i,j)=1.0 + if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) < 1.0) fill(i,j)=1.0 enddo enddo call pass_var(fill,G%Domain) @@ -588,9 +607,11 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t !! local model grid and native vertical levels. real, allocatable, dimension(:) :: z_in !< Cell grid values for input data. real, allocatable, dimension(:) :: z_edges_in !< Cell grid edge values for input data. - real, intent(out) :: missing_value - logical, intent(in) :: reentrant_x, tripolar_n - logical, intent(in), optional :: homogenize + real, intent(out) :: missing_value !< The missing value in the returned array. + 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, dimension(:,:), allocatable :: tr_in,tr_inp !< A 2-d array for holding input data on !! native horizontal grid and extended grid @@ -616,7 +637,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t 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 :: ni, nj, nz ! global grid size integer :: id_clock_read integer, dimension(4) :: fld_sz character(len=12) :: dim_name(4) @@ -628,7 +648,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t real, dimension(SZI_(G),SZJ_(G)) :: good2,fill2 real, dimension(SZI_(G),SZJ_(G)) :: nlevs - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isg = G%isg ; ieg = G%ieg ; jsg = G%jsg ; jeg = G%jeg @@ -730,7 +750,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (add_np) then last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) .gt. abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then pole = pole+last_row(i) npole = npole+1.0 endif @@ -750,13 +770,13 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call mpp_sync() call mpp_broadcast(tr_inp,id*jdp,root_PE()) - call mpp_sync_self () + call mpp_sync_self() mask_in=0.0 do j=1,jdp do i=1,id - if (abs(tr_inp(i,j)-missing_value) .gt. abs(roundoff*missing_value)) then + 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) * conversion else @@ -785,7 +805,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t mask_out=1.0 do j=js,je do i=is,ie - if (abs(tr_out(i,j)-missing_value) .lt. abs(roundoff*missing_value)) mask_out(i,j)=0. + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0. enddo enddo @@ -794,14 +814,14 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t nPoints = 0 ; varAvg = 0. do j=js,je do i=is,ie - if (mask_out(i,j) .lt. 1.0) then + 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) .and. mask_out(i,j) .lt. 1.0) fill(i,j)=1.0 + if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) < 1.0) fill(i,j)=1.0 enddo enddo call pass_var(fill,G%Domain) @@ -962,7 +982,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) endif @@ -972,7 +992,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) do n=1,niter do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) Isum = 1.0/bsum res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& @@ -990,7 +1010,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) zi(:,:)=mp(1:ni,1:nj) mp = fill_boundaries(zi,cyclic_x,tripolar_n) -end do +enddo diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 6e829c2072..664f87ad3f 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -9,23 +9,25 @@ module MOM_intrinsic_functions !* * !********+*********+*********+*********+*********+*********+*********+** - implicit none - private +implicit none ; private - public :: invcosh +public :: invcosh - contains +contains - function invcosh(x) - real, intent(in) :: x - real :: invcosh +!> Evaluate the inverse cosh, either using a math library or an +!! equivalent expression +function invcosh(x) + real, intent(in) :: x !< The argument of the inverse of cosh. NaNs will + !! occur if x<1, but there is no error checking + real :: invcosh #ifdef __INTEL_COMPILER - invcosh=acosh(x) + invcosh = acosh(x) #else - invcosh=log(x+sqrt(x*x-1)) + invcosh = log(x+sqrt(x*x-1)) #endif - end function invcosh +end function invcosh end module MOM_intrinsic_functions diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index d708fcdf27..178924d0d7 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -216,7 +216,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit call MOM_error(WARNING, "MOM_io create_file: "//trim(vars(k)%name)//& " has unrecognized t_grid "//trim(vars(k)%t_grid)) end select - end do + enddo if ((use_lath .or. use_lonh .or. use_latq .or. use_lonq)) then if (.not.domain_set) call MOM_error(FATAL, "create_file: "//& @@ -227,8 +227,9 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit if ((use_layer .or. use_int) .and. .not.present(GV)) call MOM_error(FATAL, & "create_file: A vertical grid type is required to create a file with a vertical coordinate.") -! Specify all optional arguments to mpp_write_meta: name, units, longname, cartesian, calendar, sense, domain, data, min) -! Otherwise if optional arguments are added to mpp_write_meta the compiler may (and in case of GNU is) get confused and crash. +! Specify all optional arguments to mpp_write_meta: name, units, longname, cartesian, calendar, sense, +! domain, data, min). Otherwise if optional arguments are added to mpp_write_meta the compiler may +! (and in case of GNU does) get confused and crash. if (use_lath) & call mpp_write_meta(unit, axis_lath, name="lath", units=y_axis_units, longname="Latitude", & cartesian='Y', domain = y_domain, data=gridLatT(jsg:jeg)) @@ -259,13 +260,13 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit ! Set appropriate units, depending on the value. if (timeunit < 0.0) then time_units = "days" ! The default value. - else if ((timeunit >= 0.99) .and. (timeunit < 1.01)) then + elseif ((timeunit >= 0.99) .and. (timeunit < 1.01)) then time_units = "seconds" - else if ((timeunit >= 3599.0) .and. (timeunit < 3601.0)) then + elseif ((timeunit >= 3599.0) .and. (timeunit < 3601.0)) then time_units = "hours" - else if ((timeunit >= 86399.0) .and. (timeunit < 86401.0)) then + elseif ((timeunit >= 86399.0) .and. (timeunit < 86401.0)) then time_units = "days" - else if ((timeunit >= 3.0e7) .and. (timeunit < 3.2e7)) then + elseif ((timeunit >= 3.0e7) .and. (timeunit < 3.2e7)) then time_units = "years" else write(time_units,'(es8.2," s")') timeunit @@ -322,7 +323,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit end select pack = 1 - if(present(checksums)) then + if (present(checksums)) then call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack = pack, checksum=checksums(k,:)) else @@ -425,17 +426,18 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit ! call mpp_get_field_atts(fields(i),name) ! !if (trim(name) /= trim(vars%name) then ! !write (mesg,'("Reopening file ",a," variable ",a," is called ",a,".")',& -! ! filename,vars%name,name); +! ! filename,vars%name,name) ! !call MOM_error(NOTE,"MOM_io: "//mesg) ! enddo endif end subroutine reopen_file - +!> Read the data associated with a named axis in a file subroutine read_axis_data(filename, axis_name, var) - character(len=*), intent(in) :: filename, axis_name - real, dimension(:), intent(out) :: var + character(len=*), intent(in) :: filename !< Name of the file to read + character(len=*), intent(in) :: axis_name !< Name of the axis to read + real, dimension(:), intent(out) :: var !< The axis location data integer :: i,len,unit, ndim, nvar, natt, ntime logical :: axis_found @@ -635,19 +637,19 @@ end function var_desc !! All arguments are optional, except the vardesc type to be modified. subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & cmor_field_name, cmor_units, cmor_longname, conversion, caller) - type(vardesc), intent(inout) :: vd !< vardesc type that is modified - character(len=*), optional, intent(in) :: name !< name of variable - character(len=*), optional, intent(in) :: units !< units of variable - character(len=*), optional, intent(in) :: longname !< long name of variable - character(len=*), optional, intent(in) :: hor_grid !< horizonal staggering of variable - character(len=*), optional, intent(in) :: z_grid !< vertical staggering of variable - character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 - character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name - character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable - character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name - real , optional, intent(in) :: conversion !< for unit conversions, such as needed to - !! convert from intensive to extensive - character(len=*), optional, intent(in) :: caller !< calling routine? + type(vardesc), intent(inout) :: vd !< vardesc type that is modified + character(len=*), optional, intent(in) :: name !< name of variable + character(len=*), optional, intent(in) :: units !< units of variable + character(len=*), optional, intent(in) :: longname !< long name of variable + character(len=*), optional, intent(in) :: hor_grid !< horizonal staggering of variable + character(len=*), optional, intent(in) :: z_grid !< vertical staggering of variable + character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1 + character(len=*), optional, intent(in) :: cmor_field_name !< CMOR name + character(len=*), optional, intent(in) :: cmor_units !< CMOR physical dimensions of variable + character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name + real , optional, intent(in) :: conversion !< for unit conversions, such as needed + !! to convert from intensive to extensive + character(len=*), optional, intent(in) :: caller !< calling routine? character(len=120) :: cllr cllr = "mod_vardesc" diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index adf6bac926..4e8234f697 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -147,7 +147,8 @@ module MOM_restart !> Register a 3-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) - real, dimension(:,:,:), target :: f_ptr !< A pointer to the field to be read or written + 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. @@ -177,7 +178,8 @@ 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) - real, dimension(:,:,:,:), target :: f_ptr !< A pointer to the field to be read or written + 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. @@ -207,7 +209,8 @@ 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) - real, dimension(:,:), target :: f_ptr !< A pointer to the field to be read or written + 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. @@ -237,7 +240,7 @@ 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) - real, dimension(:), target :: f_ptr !< A pointer to the field to be read or written + 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. @@ -267,7 +270,7 @@ 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) - real, target :: f_ptr !< A pointer to the field to be read or written + 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. @@ -300,7 +303,8 @@ end subroutine register_restart_field_ptr0d !> 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, & hor_grid, z_grid, t_grid) - real, dimension(:,:,:,:), target :: f_ptr !< A pointer to the field to be read or written + 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 logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -326,7 +330,8 @@ 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, & hor_grid, z_grid, t_grid) - real, dimension(:,:,:), target :: f_ptr !< A pointer to the field to be read or written + 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 logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -352,7 +357,8 @@ 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, & hor_grid, z_grid, t_grid) - real, dimension(:,:), target :: f_ptr !< A pointer to the field to be read or written + 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 logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -380,7 +386,7 @@ 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, & hor_grid, z_grid, t_grid) - real, dimension(:), target :: f_ptr !< A pointer to the field to be read or written + 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 logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -408,7 +414,7 @@ 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, & t_grid) - real, target :: f_ptr !< A pointer to the field to be read or written + 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 logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -432,8 +438,8 @@ end subroutine register_restart_field_0d !> query_initialized_name determines whether a named field has been successfully !! read from a restart file yet. function query_initialized_name(name, CS) result(query_initialized) - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine returns .true. if the field referred to by name has ! initialized from a restart file, and .false. otherwise. @@ -467,9 +473,10 @@ function query_initialized_name(name, CS) result(query_initialized) end function query_initialized_name +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_0d(f_ptr, CS) result(query_initialized) - real, target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -485,7 +492,7 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr0d(m)%p,f_ptr)) then + if (associated(CS%var_ptr0d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -496,9 +503,10 @@ function query_initialized_0d(f_ptr, CS) result(query_initialized) end function query_initialized_0d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_1d(f_ptr, CS) result(query_initialized) - real, dimension(:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -514,7 +522,7 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr1d(m)%p,f_ptr)) then + if (associated(CS%var_ptr1d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -525,9 +533,11 @@ function query_initialized_1d(f_ptr, CS) result(query_initialized) end function query_initialized_1d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_2d(f_ptr, CS) result(query_initialized) - real, dimension(:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -543,7 +553,7 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr2d(m)%p,f_ptr)) then + if (associated(CS%var_ptr2d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -554,9 +564,11 @@ function query_initialized_2d(f_ptr, CS) result(query_initialized) end function query_initialized_2d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_3d(f_ptr, CS) result(query_initialized) - real, dimension(:,:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -572,7 +584,7 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr3d(m)%p,f_ptr)) then + if (associated(CS%var_ptr3d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -583,9 +595,11 @@ function query_initialized_3d(f_ptr, CS) result(query_initialized) end function query_initialized_3d +!> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_4d(f_ptr, CS) result(query_initialized) - real, dimension(:,:,:,:), target :: f_ptr - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr has ! been initialized from a restart file. @@ -601,7 +615,7 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr4d(m)%p,f_ptr)) then + if (associated(CS%var_ptr4d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -612,10 +626,12 @@ function query_initialized_4d(f_ptr, CS) result(query_initialized) end function query_initialized_4d +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) - real, target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -632,7 +648,7 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr0d(m)%p,f_ptr)) then + if (associated(CS%var_ptr0d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -649,10 +665,13 @@ function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_0d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -669,7 +688,7 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr1d(m)%p,f_ptr)) then + if (associated(CS%var_ptr1d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -686,10 +705,13 @@ function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_1d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -706,7 +728,7 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr2d(m)%p,f_ptr)) then + if (associated(CS%var_ptr2d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -723,10 +745,13 @@ function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_2d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -743,7 +768,7 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr3d(m)%p,f_ptr)) then + if (associated(CS%var_ptr3d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -760,10 +785,13 @@ function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_3d_name +!> Indicate whether the field pointed to by f_ptr or with the specified variable +!! name has been initialized from a restart file. function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) - real, dimension(:,:,:,:), target :: f_ptr - character(len=*) :: name - type(MOM_restart_CS), pointer :: CS + real, dimension(:,:,:,:), & + target, intent(in) :: f_ptr !< A pointer to the field that is being queried + character(len=*), intent(in) :: name !< The name of the field that is being queried + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object (intent in) logical :: query_initialized ! This subroutine tests whether the field pointed to by f_ptr or with the ! specified variable name has been initialized from a restart file. @@ -780,7 +808,7 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) query_initialized = .false. n = CS%novars+1 do m=1,CS%novars - if (ASSOCIATED(CS%var_ptr4d(m)%p,f_ptr)) then + if (associated(CS%var_ptr4d(m)%p,f_ptr)) then if (CS%restart_field(m)%initialized) query_initialized = .true. n = m ; exit endif @@ -797,14 +825,17 @@ function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) end function query_initialized_4d_name +!> save_restart saves all registered variables to restart files. subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) -! save_restart saves all registered variables to restart files. - character(len=*), intent(in) :: directory - type(time_type), intent(in) :: time - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - type(MOM_restart_CS), pointer :: CS - logical, optional, intent(in) :: time_stamped - character(len=*), optional, intent(in) :: filename + character(len=*), intent(in) :: directory !< The directory where the restart files + !! are to be written + type(time_type), intent(in) :: time !< The current model time + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(MOM_restart_CS), pointer :: CS !< The control structure returned by a previous + !! call to restart_init. + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp + !! to the restart file names. + character(len=*), optional, intent(in) :: filename !< A filename that overrides the name in CS%restartfile. type(verticalGrid_type), optional, intent(in) :: GV !< The ocean's vertical grid structure ! Arguments: directory - The directory where the restart file goes. ! (in) time - The time of this restart file. @@ -819,8 +850,8 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that ! are to be read from the restart file. type(fieldtype) :: fields(CS%max_fields) ! - character(len=200) :: restartpath ! The restart file path (dir/file). - character(len=80) :: restartname ! The restart file name (no dir). + character(len=512) :: restartpath ! The restart file path (dir/file). + character(len=256) :: restartname ! The restart file name (no dir). character(len=8) :: suffix ! A suffix (like _2) that is appended ! to the name of files after the first. integer(kind=8) :: var_sz, size_in_file ! The size in bytes of each variable @@ -869,7 +900,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) seconds = seconds + 60*minute + 3600*hour if (year <= 9999) then write(restartname,'("_Y",I4.4,"_D",I3.3,"_S",I5.5)') year, days, seconds - else if (year <= 99999) then + elseif (year <= 99999) then write(restartname,'("_Y",I5.5,"_D",I3.3,"_S",I5.5)') year, days, seconds else write(restartname,'("_Y",I10.10,"_D",I3.3,"_S",I5.5)') year, days, seconds @@ -914,14 +945,14 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) - if(restartname(length-2:length) == '.nc') then + if (restartname(length-2:length) == '.nc') then restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' else restartname = restartname(1:length) //'.'//trim(filename_appendix) - end if - end if + endif + endif restartpath = trim(directory)// trim(restartname) @@ -956,15 +987,15 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !Prepare the checksum of the restart fields to be written to restart files call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) do m=start_var,next_var-1 - if (ASSOCIATED(CS%var_ptr3d(m)%p)) then + if (associated(CS%var_ptr3d(m)%p)) then check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) - elseif (ASSOCIATED(CS%var_ptr2d(m)%p)) then + elseif (associated(CS%var_ptr2d(m)%p)) then check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) - elseif (ASSOCIATED(CS%var_ptr4d(m)%p)) then + elseif (associated(CS%var_ptr4d(m)%p)) then check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) - elseif (ASSOCIATED(CS%var_ptr1d(m)%p)) then + elseif (associated(CS%var_ptr1d(m)%p)) then check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr1d(m)%p) - elseif (ASSOCIATED(CS%var_ptr0d(m)%p)) then + elseif (associated(CS%var_ptr0d(m)%p)) then check_val(m-start_var+1,1) = mpp_chksum(CS%var_ptr0d(m)%p) endif enddo @@ -979,19 +1010,19 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) do m=start_var,next_var-1 - if (ASSOCIATED(CS%var_ptr3d(m)%p)) then + if (associated(CS%var_ptr3d(m)%p)) then call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & CS%var_ptr3d(m)%p, restart_time) - elseif (ASSOCIATED(CS%var_ptr2d(m)%p)) then + elseif (associated(CS%var_ptr2d(m)%p)) then call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & CS%var_ptr2d(m)%p, restart_time) - elseif (ASSOCIATED(CS%var_ptr4d(m)%p)) then + elseif (associated(CS%var_ptr4d(m)%p)) then call write_field(unit,fields(m-start_var+1), G%Domain%mpp_domain, & CS%var_ptr4d(m)%p, restart_time) - elseif (ASSOCIATED(CS%var_ptr1d(m)%p)) then + elseif (associated(CS%var_ptr1d(m)%p)) then call write_field(unit, fields(m-start_var+1), CS%var_ptr1d(m)%p, & restart_time) - elseif (ASSOCIATED(CS%var_ptr0d(m)%p)) then + elseif (associated(CS%var_ptr0d(m)%p)) then call write_field(unit, fields(m-start_var+1), CS%var_ptr0d(m)%p, & restart_time) endif @@ -1052,7 +1083,7 @@ subroutine restore_state(filename, directory, day, G, CS) real, allocatable :: time_vals(:) type(fieldtype), allocatable :: fields(:) logical :: check_exist, is_there_a_checksum - integer(kind=8),dimension(1) :: checksum_file + integer(kind=8),dimension(3) :: checksum_file integer(kind=8) :: checksum_data if (.not.associated(CS)) call MOM_error(FATAL, "MOM_restart " // & @@ -1145,7 +1176,7 @@ subroutine restore_state(filename, directory, day, G, CS) call get_file_atts(fields(i),name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then check_exist = mpp_attribute_exist(fields(i),"checksum") - checksum_file = -1 + checksum_file(:) = -1 checksum_data = -1 is_there_a_checksum = .false. if ( check_exist ) then @@ -1154,41 +1185,41 @@ subroutine restore_state(filename, directory, day, G, CS) endif if (.NOT. CS%checksum_required ) is_there_a_checksum = .false. ! Do not need to do data checksumming. - if (ASSOCIATED(CS%var_ptr1d(m)%p)) then + if (associated(CS%var_ptr1d(m)%p)) then ! Read a 1d array, which should be invariant to domain decomposition. call read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, & no_domain=.true., timelevel=1) if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr1d(m)%p) - elseif (ASSOCIATED(CS%var_ptr0d(m)%p)) then ! Read a scalar... + elseif (associated(CS%var_ptr0d(m)%p)) then ! Read a scalar... call read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, & no_domain=.true., timelevel=1) if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr0d(m)%p) - elseif ((pos == 0) .and. ASSOCIATED(CS%var_ptr2d(m)%p)) then ! Read a non-decomposed 2d array. + elseif ((pos == 0) .and. associated(CS%var_ptr2d(m)%p)) then ! Read a non-decomposed 2d array. ! Probably should query the field type to make sure that the sizes are right. call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & no_domain=.true., timelevel=1) if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) - elseif ((pos == 0) .and. ASSOCIATED(CS%var_ptr3d(m)%p)) then ! Read a non-decomposed 3d array. + elseif ((pos == 0) .and. associated(CS%var_ptr3d(m)%p)) then ! Read a non-decomposed 3d array. ! Probably should query the field type to make sure that the sizes are right. call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & no_domain=.true., timelevel=1) if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) - elseif ((pos == 0) .and. ASSOCIATED(CS%var_ptr4d(m)%p)) then ! Read a non-decomposed 4d array. + elseif ((pos == 0) .and. associated(CS%var_ptr4d(m)%p)) then ! Read a non-decomposed 4d array. ! Probably should query the field type to make sure that the sizes are right. call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & no_domain=.true., timelevel=1) if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) elseif (unit_is_global(n) .or. G%Domain%use_io_layout) then - if (ASSOCIATED(CS%var_ptr3d(m)%p)) then + if (associated(CS%var_ptr3d(m)%p)) then ! Read 3d array... Time level 1 is always used. call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & G%Domain, 1, position=pos) if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) - elseif (ASSOCIATED(CS%var_ptr2d(m)%p)) then ! Read 2d array... + elseif (associated(CS%var_ptr2d(m)%p)) then ! Read 2d array... call MOM_read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & G%Domain, 1, position=pos) if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) - elseif (ASSOCIATED(CS%var_ptr4d(m)%p)) then ! Read 4d array... + elseif (associated(CS%var_ptr4d(m)%p)) then ! Read 4d array... call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & G%Domain, 1, position=pos) if ( is_there_a_checksum ) checksum_data = mpp_chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) @@ -1235,7 +1266,7 @@ subroutine restore_state(filename, directory, day, G, CS) exit endif - if (ASSOCIATED(CS%var_ptr3d(m)%p)) then + if (associated(CS%var_ptr3d(m)%p)) then if (ntime == 0) then call read_field(unit(n), fields(i), & CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) @@ -1243,7 +1274,7 @@ subroutine restore_state(filename, directory, day, G, CS) call read_field(unit(n), fields(i), & CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), 1) endif - elseif (ASSOCIATED(CS%var_ptr2d(m)%p)) then + elseif (associated(CS%var_ptr2d(m)%p)) then if (ntime == 0) then call read_field(unit(n), fields(i), & CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) @@ -1251,7 +1282,7 @@ subroutine restore_state(filename, directory, day, G, CS) call read_field(unit(n), fields(i), & CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), 1) endif - elseif (ASSOCIATED(CS%var_ptr4d(m)%p)) then + elseif (associated(CS%var_ptr4d(m)%p)) then if (ntime == 0) then call read_field(unit(n), fields(i), & CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) @@ -1265,7 +1296,7 @@ subroutine restore_state(filename, directory, day, G, CS) endif endif - if(is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then + if (is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then write (mesg,'(a,Z16,a,Z16,a)') "Checksum of input field "// trim(varname)//" ",checksum_data,& " does not match value ", checksum_file(1), & " stored in "//trim(unit_path(n)//"." ) @@ -1408,9 +1439,9 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & ! (in/out) CS - The control structure returned by a previous call to ! restart_init. - 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 + character(len=256) :: filepath ! The path (dir/file) to the file being opened. + character(len=256) :: fname ! The name of the current file. + character(len=8) :: suffix ! A suffix (like "_2") that is added to any ! additional restart files. ! character(len=256) :: mesg ! A message for warnings. integer :: num_restart ! The number of restart files that have already @@ -1447,14 +1478,14 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) - if(restartname(length-2:length) == '.nc') then + if (restartname(length-2:length) == '.nc') then restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' else restartname = restartname(1:length) //'.'//trim(filename_appendix) - end if - end if + endif + endif filepath = trim(directory) // trim(restartname) if (num_restart < 10) then @@ -1531,10 +1562,14 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & end function open_restart_units +!> Initialize this module and set up a restart control structure. subroutine restart_init(param_file, CS, restart_root) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(MOM_restart_CS), pointer :: CS - character(len=*), optional, intent(in) :: restart_root + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object that is allocated here + character(len=*), optional, & + intent(in) :: restart_root !< A filename root that overrides the value + !! set by RESTARTFILE to enable the use of this module by + !! other components than MOM. ! Arguments: param_file - A structure indicating the open file to parse for ! model parameter values. ! (in/out) CS - A pointer that is set to point to the control structure @@ -1590,8 +1625,9 @@ subroutine restart_init(param_file, CS, restart_root) end subroutine restart_init +!> Indicate that all variables have now been registered. subroutine restart_init_end(CS) - type(MOM_restart_CS), pointer :: CS + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS)) then if (CS%novars == 0) call restart_end(CS) @@ -1599,8 +1635,9 @@ subroutine restart_init_end(CS) end subroutine restart_init_end +!> Deallocate memory associated with a MOM_restart_CS variable. subroutine restart_end(CS) - type(MOM_restart_CS), pointer :: CS + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object if (associated(CS%restart_field)) deallocate(CS%restart_field) if (associated(CS%var_ptr0d)) deallocate(CS%var_ptr0d) @@ -1613,7 +1650,7 @@ subroutine restart_end(CS) end subroutine restart_end subroutine restart_error(CS) - type(MOM_restart_CS), pointer :: CS + type(MOM_restart_CS), pointer :: CS !< A pointer to a MOM_restart_CS object ! Arguments: CS - A pointer that is set to point to the control structure ! for this module. (Intent in.) character(len=16) :: num ! String for error messages diff --git a/src/framework/MOM_safe_alloc.F90 b/src/framework/MOM_safe_alloc.F90 index 491d4563b6..5b4d331645 100644 --- a/src/framework/MOM_safe_alloc.F90 +++ b/src/framework/MOM_safe_alloc.F90 @@ -14,11 +14,13 @@ module MOM_safe_alloc public safe_alloc_ptr, safe_alloc_alloc +!> Allocate a pointer to a 1-d, 2-d or 3-d array interface safe_alloc_ptr module procedure safe_alloc_ptr_3d_2arg, safe_alloc_ptr_2d_2arg module procedure safe_alloc_ptr_3d, safe_alloc_ptr_2d, safe_alloc_ptr_1d end interface safe_alloc_ptr +!> Allocate a 2-d or 3-d allocatable array interface safe_alloc_alloc module procedure safe_alloc_allocatable_3d, safe_alloc_allocatable_2d end interface safe_alloc_alloc @@ -34,11 +36,12 @@ module MOM_safe_alloc contains +!> Allocate a pointer to a 1-d array subroutine safe_alloc_ptr_1d(ptr, i1, i2) - real, pointer :: ptr(:) - integer, intent(in) :: i1 - integer, optional, intent(in) :: i2 - if (.not.ASSOCIATED(ptr)) then + real, dimension(:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: i1 !< The size of the array, or its starting index if i2 is present + integer, optional, intent(in) :: i2 !< The ending index of the array + if (.not.associated(ptr)) then if (present(i2)) then allocate(ptr(i1:i2)) else @@ -48,55 +51,68 @@ subroutine safe_alloc_ptr_1d(ptr, i1, i2) endif end subroutine safe_alloc_ptr_1d +!> Allocate a pointer to a 2-d array based on its dimension sizes subroutine safe_alloc_ptr_2d_2arg(ptr, ni, nj) - real, pointer :: ptr(:,:) - integer, intent(in) :: ni, nj - if (.not.ASSOCIATED(ptr)) then + real, dimension(:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: ni, nj !< The sizes of the 1st and 2nd dimensions of the array + if (.not.associated(ptr)) then allocate(ptr(ni,nj)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_ptr_2d_2arg +!> Allocate a pointer to a 3-d array based on its dimension sizes subroutine safe_alloc_ptr_3d_2arg(ptr, ni, nj, nk) - real, pointer :: ptr(:,:,:) - integer, intent(in) :: ni, nj, nk - if (.not.ASSOCIATED(ptr)) then + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: ni, nj !< The sizes of the 1st and 2nd dimensions of the array + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension + if (.not.associated(ptr)) then allocate(ptr(ni,nj,nk)) ptr(:,:,:) = 0.0 endif end subroutine safe_alloc_ptr_3d_2arg +!> Allocate a pointer to a 2-d array based on its index starting and ending values subroutine safe_alloc_ptr_2d(ptr, is, ie, js, je) - real, pointer :: ptr(:,:) - integer, intent(in) :: is, ie, js, je - if (.not.ASSOCIATED(ptr)) then + real, dimension(:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is, ie !< The start and end indices to allocate for the 1st dimension + integer, intent(in) :: js, je !< The start and end indices to allocate for the 2nd dimension + if (.not.associated(ptr)) then allocate(ptr(is:ie,js:je)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_ptr_2d +!> Allocate a pointer to a 3-d array based on its index starting and ending values subroutine safe_alloc_ptr_3d(ptr, is, ie, js, je, nk) - real, pointer :: ptr(:,:,:) - integer, intent(in) :: is, ie, js, je, nk - if (.not.ASSOCIATED(ptr)) then + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is, ie !< The start and end indices to allocate for the 1st dimension + integer, intent(in) :: js, je !< The start and end indices to allocate for the 2nd dimension + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension + if (.not.associated(ptr)) then allocate(ptr(is:ie,js:je,nk)) ptr(:,:,:) = 0.0 endif end subroutine safe_alloc_ptr_3d +!> Allocate a 2-d allocatable array based on its index starting and ending values subroutine safe_alloc_allocatable_2d(ptr, is, ie, js, je) - real, allocatable :: ptr(:,:) - integer, intent(in) :: is, ie, js, je - if (.not.ALLOCATED(ptr)) then + real, dimension(:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is, ie !< The start and end indices to allocate for the 1st dimension + integer, intent(in) :: js, je !< The start and end indices to allocate for the 2nd dimension + if (.not.allocated(ptr)) then allocate(ptr(is:ie,js:je)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_allocatable_2d +!> Allocate a 3-d allocatable array based on its index starting and ending values subroutine safe_alloc_allocatable_3d(ptr, is, ie, js, je, nk) - real, allocatable :: ptr(:,:,:) - integer, intent(in) :: is, ie, js, je, nk - if (.not.ALLOCATED(ptr)) then + real, dimension(:,:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is, ie !< The start and end indices to allocate for the 1st dimension + integer, intent(in) :: js, je !< The start and end indices to allocate for the 2nd dimension + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension + if (.not.allocated(ptr)) then allocate(ptr(is:ie,js:je,nk)) ptr(:,:,:) = 0.0 endif diff --git a/src/framework/MOM_spatial_means.F90 b/src/framework/MOM_spatial_means.F90 index e0cfac465c..9e2d312887 100644 --- a/src/framework/MOM_spatial_means.F90 +++ b/src/framework/MOM_spatial_means.F90 @@ -23,9 +23,10 @@ module MOM_spatial_means contains +!> Return the global area mean of a variable. This uses reproducing sums. function global_area_mean(var,G) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var + real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to average real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_mean @@ -40,9 +41,10 @@ function global_area_mean(var,G) end function global_area_mean +!> Return the global area integral of a variable. This uses reproducing sums. function global_area_integral(var,G) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var + real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to integrate real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_integral @@ -57,10 +59,11 @@ function global_area_integral(var,G) 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) 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 + 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, in H (usually m or kg m-2) real, dimension(SZK_(GV)) :: global_layer_mean @@ -86,7 +89,7 @@ function global_layer_mean(var, h, G, GV) end function global_layer_mean -!> Find the global thickness-weighted mean of a variable. +!> Find the global thickness-weighted mean of a variable. This uses reproducing sums. function global_volume_mean(var, h, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -114,7 +117,7 @@ function global_volume_mean(var, h, G, GV) end function global_volume_mean -!> Find the global mass-weighted integral of a variable +!> Find the global mass-weighted integral of a variable. This uses reproducing sums. function global_mass_integral(h, G, GV, var, on_PE_only) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -158,11 +161,14 @@ function global_mass_integral(h, G, GV, var, on_PE_only) end function global_mass_integral +!> 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. subroutine global_i_mean(array, i_mean, G, mask) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array - real, dimension(SZJ_(G)), intent(out) :: i_mean - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: mask + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged + real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mask !< An array used for weighting the i-mean ! This subroutine determines the global mean of a field along rows of ! constant i, returning it in a 1-d array using the local indexing. @@ -236,11 +242,14 @@ subroutine global_i_mean(array, i_mean, G, mask) end subroutine global_i_mean +!> Determine the global mean of a field along rows of constant j, returning it +!! in a 1-d array using the local indexing. This uses reproducing sums. subroutine global_j_mean(array, j_mean, G, mask) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array - real, dimension(SZI_(G)), intent(out) :: j_mean - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: mask + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged + real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis + real, dimension(SZI_(G),SZJ_(G)), & + optional, intent(in) :: mask !< An array used for weighting the j-mean ! This subroutine determines the global mean of a field along rows of ! constant j, returning it in a 1-d array using the local indexing. @@ -316,7 +325,7 @@ end subroutine global_j_mean !> Adjust 2d array such that area mean is zero without moving the zero contour subroutine adjust_area_mean_to_zero(array, G, scaling) - type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(ocean_grid_type), intent(in) :: G !< Grid structure real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted real, optional, intent(out) :: scaling !< The scaling factor used ! Local variables diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index c0f3ba2b28..643b150219 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -27,14 +27,14 @@ module MOM_string_functions contains +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. function lowercase(input_string) + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: lowercase !< The modified output string ! This function returns a string in which all uppercase letters have been ! replaced by their lowercase counterparts. It is loosely based on the ! lowercase function in mpp_util.F90. - ! Arguments - character(len=*), intent(in) :: input_string - character(len=len(input_string)) :: lowercase - ! Local variables integer, parameter :: co=iachar('a')-iachar('A') ! case offset integer :: k @@ -42,16 +42,17 @@ function lowercase(input_string) do k=1, len_trim(input_string) if (lowercase(k:k) >= 'A' .and. lowercase(k:k) <= 'Z') & lowercase(k:k) = achar(ichar(lowercase(k:k))+co) - end do + enddo end function lowercase +!> Return a string in which all uppercase letters have been replaced by +!! their lowercase counterparts. function uppercase(input_string) - character(len=*), intent(in) :: input_string - character(len=len(input_string)) :: uppercase + character(len=*), intent(in) :: input_string !< The string to modify + character(len=len(input_string)) :: uppercase !< The modified output string ! This function returns a string in which all lowercase letters have been ! replaced by their uppercase counterparts. It is loosely based on the ! uppercase function in mpp_util.F90. - ! Arguments integer, parameter :: co=iachar('A')-iachar('a') ! case offset integer :: k @@ -59,28 +60,26 @@ function uppercase(input_string) do k=1, len_trim(input_string) if (uppercase(k:k) >= 'a' .and. uppercase(k:k) <= 'z') & uppercase(k:k) = achar(ichar(uppercase(k:k))+co) - end do + enddo end function uppercase +!> Returns a character string of a left-formatted integer +!! e.g. "123 " (assumes 19 digit maximum) function left_int(i) -! Returns a character string of a left-formatted integer -! e.g. "123 " (assumes 19 digit maximum) - ! Arguments - character(len=19) :: left_int - integer, intent(in) :: i - ! Local variables + integer, intent(in) :: i !< The integer to convert to a string + character(len=19) :: left_int !< The output string + character(len=19) :: tmp write(tmp(1:19),'(I19)') i write(left_int(1:19),'(A)') adjustl(tmp) end function left_int +!> Returns a character string of a comma-separated, compact formatted, +!! integers e.g. "1, 2, 3, 4" function left_ints(i) -! Returns a character string of a comma-separated, compact formatted, -! integers e.g. "1, 2, 3, 4" - ! Arguments - character(len=1320) :: left_ints - integer, intent(in) :: i(:) - ! Local variables + integer, intent(in) :: i(:) !< The array of integers to convert to a string + character(len=1320) :: left_ints !< The output string + character(len=1320) :: tmp integer :: j write(left_ints(1:1320),'(A)') trim(left_int(i(1))) @@ -92,10 +91,11 @@ function left_ints(i) endif end function left_ints +!> Returns a left-justified string with a real formatted like '(G)' function left_real(val) - real, intent(in) :: val - character(len=32) :: left_real -! Returns a left-justified string with a real formatted like '(G)' + real, intent(in) :: val !< The real variable to convert to a string + character(len=32) :: left_real !< The output string + integer :: l, ind if ((abs(val) < 1.0e4) .and. (abs(val) >= 1.0e-3)) then @@ -143,17 +143,18 @@ function left_real(val) left_real = adjustl(left_real) end function left_real +!> Returns a character string of a comma-separated, compact formatted, reals +!! e.g. "1., 2., 5*3., 5.E2" function left_reals(r,sep) -! Returns a character string of a comma-separated, compact formatted, reals -! e.g. "1., 2., 5*3., 5.E2" - ! Arguments - character(len=1320) :: left_reals - real, intent(in) :: r(:) - character(len=*), optional :: sep - ! Local variables + real, intent(in) :: r(:) !< The array of real variables to convert to a string + character(len=*), optional, intent(in) :: sep !< The separator between + !! successive values, by default it is ', '. + character(len=1320) :: left_reals !< The output string + integer :: j, n, b, ns logical :: doWrite character(len=10) :: separator + n=1 ; doWrite=.true. ; left_reals='' ; b=1 if (present(sep)) then separator=sep ; ns=len(sep) @@ -183,11 +184,10 @@ function left_reals(r,sep) enddo end function left_reals +!> Returns True if the string can be read/parsed to give the exact value of "val" function isFormattedFloatEqualTo(str, val) -! Returns True if the string can be read/parsed to give the exact -! value of "val" - character(len=*), intent(in) :: str - real, intent(in) :: val + character(len=*), intent(in) :: str !< The string to parse + real, intent(in) :: val !< The real value to compare with logical :: isFormattedFloatEqualTo ! Local variables real :: scannedVal @@ -202,8 +202,8 @@ end function isFormattedFloatEqualTo !! or "" if the string is not long enough. Both spaces and commas !! are interpreted as separators. character(len=120) function extractWord(string, n) - character(len=*), intent(in) :: string - integer, intent(in) :: n + character(len=*), intent(in) :: string !< The string to scan + integer, intent(in) :: n !< Number of word to extract extractWord = extract_word(string, ' ,', n) @@ -222,7 +222,7 @@ end function extractWord extract_word = '' lastCharIsSeperator = .true. ns = len_trim(string) - i = 0; b=0; e=0; nw=0; + i = 0; b=0; e=0; nw=0 do while (i Evaluate the CPU time returned by SYSTEM_CLOCK at the start of a run subroutine write_cputime_start_clock(CS) - type(write_cputime_CS), pointer :: CS + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. ! Argument: CS - A pointer that is set to point to the control structure ! for this module integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK @@ -60,11 +62,13 @@ subroutine write_cputime_start_clock(CS) CS%prev_cputime = new_cputime end subroutine write_cputime_start_clock +!> Initialize the MOM_write_cputime module. subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=*), intent(in) :: directory - type(time_type), intent(in) :: Input_start_time - type(write_cputime_CS), pointer :: CS + character(len=*), intent(in) :: directory !< The directory where the CPU time file goes. + type(time_type), intent(in) :: Input_start_time !< The start model time of the simulation. + type(write_cputime_CS), pointer :: CS !< A pointer that may be set to point to the + !! control structure for this module. ! Arguments: param_file - A structure indicating the open file to parse for ! model parameter values. ! (in) directory - The directory where the energy file goes. @@ -106,11 +110,15 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) end subroutine MOM_write_cputime_init +!> This subroutine assesses how much CPU time the model has taken and determines how long the model +!! should be run before it saves a restart file and stops itself. subroutine write_cputime(day, n, nmax, CS) - type(time_type), intent(inout) :: day - integer, intent(in) :: n - integer, intent(inout) :: nmax - type(write_cputime_CS), pointer :: CS + type(time_type), intent(inout) :: day !< The current model time. + integer, intent(in) :: n !< The time step number of the current execution. + integer, intent(inout) :: nmax !< The number of iterations after which to stop so + !! that the simulation will not run out of CPU time. + type(write_cputime_CS), pointer :: CS !< The control structure set up by a previous + !! call to MOM_write_cputime_init. ! This subroutine assesses how much CPU time the model has ! taken and determines how long the model should be run before it ! saves a restart file and stops itself. diff --git a/src/framework/bitcount.c b/src/framework/bitcount.c deleted file mode 100644 index 58637b2f6c..0000000000 --- a/src/framework/bitcount.c +++ /dev/null @@ -1,25 +0,0 @@ -#include -#include -#include -#include -#include -/* bitcount : count 1 bits in x */ -int bitcount_(double *x) -{ -int b; -unsigned long *y; -double z; - -z = *x; -y = (unsigned long *) &z; -for (b = 0; *y !=0; *y >>= 1) - if (*y & 01) - b++; -return b; -} - -/* wrapper for IBM system */ -int bitcount(double *x) -{ - return bitcount_(x); -} diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index e8821e4c87..77a4cc82a5 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1,6 +1,6 @@ !> Implements the thermodynamic aspects of ocean / ice-shelf interactions, -! along with a crude placeholder for a later implementation of full -! ice shelf dynamics, all using the MOM framework and coding style. +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. module MOM_ice_shelf ! This file is part of MOM6. See LICENSE.md for the license. @@ -11,7 +11,7 @@ module MOM_ice_shelf use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging use MOM_domains, only : MOM_domains_init, clone_MOM_domain -use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type @@ -21,7 +21,7 @@ module MOM_ice_shelf use MOM_fixed_initialization, only : MOM_initialize_rotation use user_initialization, only : user_initialize_topography use MOM_io, only : field_exists, file_exists, MOM_read_data, write_version_number -use MOM_io, only : slasher, vardesc, var_desc, fieldtype +use MOM_io, only : slasher, fieldtype use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE use MOM_restart, only : register_restart_field, query_initialized, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS @@ -30,17 +30,21 @@ module MOM_ice_shelf use MOM_variables, only : surface use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum +use MOM_forcing_type, only : copy_common_forcing_fields use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze use MOM_EOS, only : EOS_type, EOS_init -!MJHuse MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary, initialize_ice_thickness +use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf +use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn +use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve +use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end use MOM_ice_shelf_initialize, only : initialize_ice_thickness +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary +use MOM_ice_shelf_state, only : ice_shelf_state, ice_shelf_state_end, ice_shelf_state_init use user_shelf_init, only : USER_initialize_shelf_mass, USER_update_shelf_mass use user_shelf_init, only : user_ice_shelf_CS -use constants_mod, only: GRAV -use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync -use MOM_coms, only : reproducing_sum -use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum +use MOM_coms, only : reproducing_sum, sum_across_PEs +use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum use time_interp_external_mod, only : init_external_field, time_interp_external use time_interp_external_mod, only : time_interp_external_init use time_manager_mod, only : print_time, time_type_to_real, real_to_time_type @@ -49,25 +53,18 @@ module MOM_ice_shelf #include #ifdef SYMMETRIC_LAND_ICE # define GRID_SYM_ .true. -# define NILIMB_SYM_ NIMEMB_SYM_ -# define NJLIMB_SYM_ NJMEMB_SYM_ -# define ISUMSTART_INT_ CS%grid%iscB+1 -# define JSUMSTART_INT_ CS%grid%jscB+1 #else # define GRID_SYM_ .false. -# define NILIMB_SYM_ NIMEMB_ -# define NJLIMB_SYM_ NJMEMB_ -# define ISUMSTART_INT_ CS%grid%iscB -# define JSUMSTART_INT_ CS%grid%jscB #endif public shelf_calc_flux, add_shelf_flux, initialize_ice_shelf, ice_shelf_end -public ice_shelf_save_restart, solo_time_step +public ice_shelf_save_restart, solo_time_step, add_shelf_forces !> Control structure that contains ice shelf parameters and diagnostics handles type, public :: ice_shelf_CS ; private ! Parameters - type(MOM_restart_CS), pointer :: restart_CSp => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control + !! structure for the ice shelves type(ocean_grid_type) :: grid !< Grid for the ice-shelf model !type(dyn_horgrid_type), pointer :: dG !< Dynamic grid for the ice-shelf model type(ocean_grid_type), pointer :: ocn_grid => NULL() !< A pointer to the ocean model grid @@ -75,94 +72,12 @@ module MOM_ice_shelf real :: flux_factor = 1.0 !< A factor that can be used to turn off ice shelf !! melting (flux_factor = 0). character(len=128) :: restart_output_dir = ' ' + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + type(ice_shelf_dyn_CS), pointer :: dCS => NULL() !< The control structure for the ice-shelf dynamics. + real, pointer, dimension(:,:) :: & - mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or - !! sheet, in kg m-2. - area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf, in m2. - - t_flux => NULL(), & !< The UPWARD sensible ocean heat flux at the - !! ocean-ice interface, in W m-2. - salt_flux => NULL(), & !< The downward salt flux at the ocean-ice - !! interface, in kg m-2 s-1. - lprec => NULL(), & !< The downward liquid water flux at the - !! ocean-ice interface, in kg m-2 s-1. - exch_vel_t => NULL(), & !< Sub-shelf thermal exchange velocity, in m/s - exch_vel_s => NULL(), & !< Sub-shelf salt exchange velocity, in m/s - utide => NULL(), & !< tidal velocity, in m/s - tfreeze => NULL(), & !< The freezing point potential temperature - !! an the ice-ocean interface, in deg C. - tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice - !! shelf at the ice-ocean interface, in W m-2. - !!! DNG !!! - u_shelf => NULL(), & !< the zonal (?) velocity of the ice shelf/sheet, - ! in meters per second??? on q-points (B grid) - v_shelf => NULL(), & !< the meridional velocity of the ice shelf/sheet, - !! in m/s ?? on q-points (B grid) - h_shelf => NULL(), & !< the thickness of the shelf in m, redundant - !! with mass but may make code more readable - hmask => NULL(),& !< Mask used to indicate ice-covered cells, as - !! well as partially-covered 1: fully covered, - !! solve for velocity here (for now all ice-covered - !! cells are treated the same, this may change) - !! 2: partially covered, do not solve for velocity - !! 0: no ice in cell. - !! 3: bdry condition on thickness set - not in - !! computational domain - !! -2 : default (out of computational boundary, - !! and not = 3 - !! NOTE: hmask will change over time and - !! NEEDS TO BE MAINTAINED otherwise the wrong nodes - !! will be included in velocity calcs. - u_face_mask => NULL(), & !> masks for velocity boundary conditions - v_face_mask => NULL(), & !! on *C GRID* - this is because the FEM - !! cares about FACES THAT GET INTEGRATED OVER, - !! not vertices. Will represent boundary conditions - !! on computational boundary (or permanent boundary - !! between fast-moving and near-stagnant ice - !! FOR NOW: 1=interior bdry, 0=no-flow boundary, - !! 2=stress bdry condition, 3=inhomogeneous - !! dirichlet boundary, 4=flux boundary: at these - !! faces a flux will be specified which will - !! override velocities; a homogeneous velocity - !! condition will be specified (this seems to give - !! the solver less difficulty) - u_face_mask_boundary => NULL(), v_face_mask_boundary => NULL(), & - u_flux_boundary_values => NULL(), v_flux_boundary_values => NULL(), & - ! needed where u_face_mask is equal to 4, similary for v_face_mask - umask => NULL(), vmask => NULL(), & !< masks on the actual degrees of freedom (B grid) - !! 1=normal node, 3=inhomogeneous boundary node, - !! 0 - no flow node (will also get ice-free nodes) - calve_mask => NULL(), & !< a mask to prevent the ice shelf front from - !! advancing past its initial position (but it may - !! retreat) - !!! OVS !!! - t_shelf => NULL(), & ! veritcally integrated temperature the ice shelf/stream... oC - ! on q-points (B grid) - tmask => NULL(), & - ! masks for temperature boundary conditions ??? - ice_visc_bilinear => NULL(), & - ice_visc_lower_tri => NULL(), & - ice_visc_upper_tri => NULL(), & - thickness_boundary_values => NULL(), & - u_boundary_values => NULL(), & - v_boundary_values => NULL(), & - h_boundary_values => NULL(), & -!!! OVS !!! - t_boundary_values => NULL(), & - - taub_beta_eff_bilinear => NULL(), & ! nonlinear part of "linearized" basal stress - exact form depends on basal law exponent - ! and/or whether flow is "hybridized" a la Goldberg 2011 - taub_beta_eff_lower_tri => NULL(), & - taub_beta_eff_upper_tri => NULL(), & - - OD_rt => NULL(), float_frac_rt => NULL(), & !< two arrays that represent averages - OD_av => NULL(), float_frac => NULL() !! of ocean values that are maintained - !! within the ice shelf module and updated based on the "ocean state". - !! OD_av is ocean depth, and float_frac is the average amount of time - !! a cell is "exposed", i.e. the column thickness is below a threshold. - !! both are averaged over the time of a diagnostic (ice velocity) - - !! [if float_frac = 1 ==> grounded; obv. counterintuitive; might fix] + utide => NULL() !< tidal velocity, in m/s real :: ustar_bg !< A minimum value for ustar under ice shelves, in m s-1. real :: cdrag !< drag coefficient under ice shelves , non-dimensional. @@ -192,71 +107,29 @@ module MOM_ice_shelf !! is initialized - so need to reorganize MOM driver. !! it will be the prognistic timestep ... maybe. - !!! all need to be initialized - logical :: solo_ice_sheet !< whether the ice model is running without being !! coupled to the ocean logical :: GL_regularize !< whether to regularize the floatation condition !! at the grounding line a la Goldberg Holland Schoof 2009 - integer :: n_sub_regularize - !< partition of cell over which to integrate for - !! interpolated grounding line the (rectangular) is - !! divided into nxn equally-sized rectangles, over which - !! basal contribution is integrated (iterative quadrature) logical :: GL_couple !< whether to let the floatation condition be !!determined by ocean column thickness means update_OD_ffrac !! will be called (note: GL_regularize and GL_couple !! should be exclusive) - - real :: A_glen_isothermal - real :: n_glen - real :: eps_glen_min - real :: C_basal_friction - real :: n_basal_friction real :: density_ocean_avg !< this does not affect ocean circulation OR thermodynamics !! it is to estimate the gravitational driving force at the !! shelf front(until we think of a better way to do it- !! but any difference will be negligible) - real :: thresh_float_col_depth ! the water column depth over which the shelf if considered to be floating - logical :: moving_shelf_front logical :: calve_to_mask real :: min_thickness_simple_calve ! min. ice shelf thickness criteria for calving real :: T0, S0 ! temp/salt at ocean surface in the restoring region real :: input_flux real :: input_thickness - real :: len_lat ! this really should be a Grid or Domain field - - - real :: velocity_update_time_step ! the time to update the velocity through the nonlinear - ! elliptic equation. i think this should be done no more often than - ! ~ once a day (maybe longer) because it will depend on ocean values - ! that are averaged over this time interval, and the solve will begin - ! to lose meaning if it is done too frequently - integer :: velocity_update_sub_counter ! there is no outer loop for the velocity solve; the counter will have to be stored - integer :: velocity_update_counter ! the "outer" timestep number - integer :: nstep_velocity ! ~ (velocity_update_time_step / time_step) - - real :: cg_tolerance, nonlinear_tolerance - integer :: cg_max_iterations - integer :: nonlin_solve_err_mode ! 1: exit vel solve based on nonlin residual - ! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm - real :: CFL_factor ! in uncoupled run, how to limit subcycled advective timestep - ! i.e. dt = CFL_factor * min (dx / u) - logical :: use_reproducing_sums !< use new reproducing sums of Bob & Alistair for - !! global sums. - !! NOTE: for this to work all tiles must have the same & of - !! elements. this means thatif a symmetric grid is being - !! used, the southwest nodes of the southwest tiles will not - !! be included in the - - - logical :: switch_var ! for debdugging - a switch to ensure some event happens only once - type(time_type) :: Time !< The component's time. type(EOS_type), pointer :: eqn_of_state => NULL() !< Type that indicates the !! equation of state to use. - logical :: shelf_mass_is_dynamic !< True if the ice shelf mass changes with time. + logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result + !! the dynamic ice-shelf model. 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 @@ -277,25 +150,20 @@ module MOM_ice_shelf id_tfreeze = -1, id_tfl_shelf = -1, & id_thermal_driving = -1, id_haline_driving = -1, & id_u_ml = -1, id_v_ml = -1, id_sbdry = -1, & - id_u_shelf = -1, id_v_shelf = -1, id_h_shelf = -1, id_h_mask = -1, & - id_u_mask = -1, id_v_mask = -1, id_t_shelf = -1, id_t_mask = -1, & - id_surf_elev = -1, id_bathym = -1, id_float_frac = -1, id_col_thick = -1, & - id_area_shelf_h = -1, id_OD_av = -1, id_float_frac_rt = -1,& + 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 !>@} - ! ids for outputting intermediate thickness in advection subroutine (debugging) - !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 integer :: id_read_mass !< An integer handle used in time interpolation of !! the ice shelf mass read from a file integer :: id_read_area !< An integer handle used in time interpolation of !! the ice shelf mass read from a file - type(diag_ctrl), pointer :: diag !< A structure that is used to control diagnostic - !! output. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. type(user_ice_shelf_CS), pointer :: user_CS => NULL() - logical :: write_output_to_file !< this is for seeing arrays w/out netcdf capability logical :: debug !< If true, write verbose checksums for debugging purposes !! and use reproducible sums end type ice_shelf_CS @@ -304,58 +172,25 @@ module MOM_ice_shelf contains -!> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) -function slope_limiter (num, denom) - real, intent(in) :: num - real, intent(in) :: denom - real :: slope_limiter - real :: r - - if (denom .eq. 0) then - slope_limiter = 0 - elseif (num*denom .le. 0) then - slope_limiter = 0 - else - r = num/denom - slope_limiter = (r+abs(r))/(1+abs(r)) - endif - -end function slope_limiter - -!> Calculate area of quadrilateral. -function quad_area (X, Y) - real, dimension(4), intent(in) :: X - real, dimension(4), intent(in) :: Y - real :: quad_area, p2, q2, a2, c2, b2, d2 - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - - p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 - a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 - b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 - quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) - -end function quad_area - !> Calculates fluxes between the ocean and ice-shelf using the three-equations !! formulation (optional to use just two equations). !! See \ref section_ICE_SHELF_equations -subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) +subroutine shelf_calc_flux(state, fluxes, Time, time_step, CS, forces) type(surface), intent(inout) :: state !< structure containing fields that !!describe the surface state of the ocean - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< structure containing pointers to - !!any possible forcing fields. - !!Unused fields have NULL ptrs. - type(time_type), intent(in) :: Time !< Start time of the fluxes. + type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + type(time_type), intent(in) :: Time !< Start time of the fluxes. real, intent(in) :: time_step !< Length of time over which !! these fluxes will be applied, in s. type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure !! returned by a previous call to !! initialize_ice_shelf. + type(mech_forcing), optional, intent(inout) :: forces !< A structure with the driving mechanical forces + + type(ocean_grid_type), pointer :: G => NULL() ! The grid structure used by the ice shelf. + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state real, dimension(SZI_(CS%grid)) :: & Rhoml, & !< Ocean mixed layer density in kg m-3. @@ -365,8 +200,14 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) !< with salinity, in units of kg m-3 psu-1. p_int !< The pressure at the ice-ocean interface, in Pa. - real, dimension(:,:), allocatable :: mass_flux !< total mass flux of freshwater across - real, dimension(:,:), allocatable :: haline_driving !< (SSS - S_boundary) ice-ocean + real, dimension(SZI_(CS%grid),SZJ_(CS%grid)) :: & + exch_vel_t, & !< Sub-shelf thermal exchange velocity, in m/s + exch_vel_s !< Sub-shelf salt exchange velocity, in m/s + + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + mass_flux !< total mass flux of freshwater across + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + haline_driving !< (SSS - S_boundary) ice-ocean !! interface, positive for melting and negative for freezing. !! This is computed as part of the ISOMIP diagnostics. real, parameter :: VK = 0.40 !< Von Karman's constant - dimensionless @@ -379,8 +220,8 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) real :: PR, SC !< The Prandtl number and Schmidt number, nondim. ! 3 equations formulation variables - real, dimension(:,:), allocatable :: Sbdry !< Salinities in the ocean at the interface - !! with the ice shelf, in PSU. + real, dimension(SZDI_(CS%grid),SZDJ_(CS%grid)) :: & + Sbdry !< Salinities in the ocean at the interface with the ice shelf, in PSU. real :: Sbdry_it real :: Sbdry1, Sbdry2, S_a, S_b, S_c ! use to find salt roots real :: dS_it !< The interface salinity change during an iteration, in PSU. @@ -408,19 +249,22 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) real :: I_Gam_T, I_Gam_S, dG_dwB, iDens real :: u_at_h, v_at_h, Isqrt2 logical :: Sb_min_set, Sb_max_set - character(4) :: stepnum - character(2) :: procnum + 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. - type(ocean_grid_type), pointer :: G real, parameter :: c2_3 = 2.0/3.0 - integer :: i, j, is, ie, js, je, ied, jed, it1, it3, iters_vel_solve + integer :: i, j, is, ie, js, je, ied, jed, it1, it3 real, parameter :: rho_fw = 1000.0 ! fresh water density + if (.not. associated(CS)) call MOM_error(FATAL, "shelf_calc_flux: "// & "initialize_ice_shelf must be called before shelf_calc_flux.") call cpu_clock_begin(id_clock_shelf) - ! useful parameters G => CS%grid + ISS => CS%ISS + + ! useful parameters is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed I_ZETA_N = 1.0 / ZETA_N LF = CS%Lat_fusion @@ -442,36 +286,36 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! these fields are already set to zero during initialization ! However, they seem to be changed somewhere and, for diagnostic ! reasons, it is better to set them to zero again. - CS%tflux_shelf(:,:) = 0.0; CS%exch_vel_t(:,:) = 0.0 - CS%lprec(:,:) = 0.0; CS%exch_vel_s(:,:) = 0.0 - CS%salt_flux(:,:) = 0.0; CS%t_flux(:,:) = 0.0 - CS%tfreeze(:,:) = 0.0 + exch_vel_t(:,:) = 0.0 ; exch_vel_s(:,:) = 0.0 + ISS%tflux_shelf(:,:) = 0.0 ; ISS%water_flux(:,:) = 0.0 + ISS%salt_flux(:,:) = 0.0; ISS%tflux_ocn(:,:) = 0.0 + ISS%tfreeze(:,:) = 0.0 ! define Sbdry to avoid Run-Time Check Failure, when melt is not computed. - ALLOCATE ( haline_driving(G%ied,G%jed) ); haline_driving(:,:) = 0.0 - ALLOCATE ( Sbdry(G%ied,G%jed) ); Sbdry(:,:) = state%sss(:,:) + haline_driving(:,:) = 0.0 + Sbdry(:,:) = state%sss(:,:) !update time CS%Time = Time - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement) then - CS%time_step = time_step - ! update shelf mass - if (CS%mass_from_file) call update_shelf_mass(G, CS, Time, fluxes) + if (CS%override_shelf_movement) then + CS%time_step = time_step + ! update shelf mass + if (CS%mass_from_file) call update_shelf_mass(G, CS, ISS, Time) endif - if (CS%DEBUG) then - call hchksum (fluxes%frac_shelf_h, "frac_shelf_h before apply melting", G%HI, haloshift=0) - call hchksum (state%sst, "sst before apply melting", G%HI, haloshift=0) - call hchksum (state%sss, "sss before apply melting", G%HI, haloshift=0) - call hchksum (state%u, "u_ml before apply melting", G%HI, haloshift=0) - call hchksum (state%v, "v_ml before apply melting", G%HI, haloshift=0) - call hchksum (state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) - endif + if (CS%DEBUG) then + call hchksum(fluxes%frac_shelf_h, "frac_shelf_h before apply melting", G%HI, haloshift=0) + call hchksum(state%sst, "sst before apply melting", G%HI, haloshift=0) + call hchksum(state%sss, "sss before apply melting", G%HI, haloshift=0) + call hchksum(state%u, "u_ml before apply melting", G%HI, haloshift=0) + call hchksum(state%v, "v_ml before apply melting", G%HI, haloshift=0) + call hchksum(state%ocean_mass, "ocean_mass before apply melting", G%HI, haloshift=0) + endif do j=js,je ! Find the pressure at the ice-ocean interface, averaged only over the ! part of the cell covered by ice shelf. - do i=is,ie ; p_int(i) = CS%g_Earth * CS%mass_shelf(i,j) ; enddo + do i=is,ie ; p_int(i) = CS%g_Earth * ISS%mass_shelf(i,j) ; enddo ! Calculate insitu densities and expansion coefficients call calculate_density(state%sst(:,j),state%sss(:,j), p_int, & @@ -488,7 +332,7 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! propose instead to allow where Hml > [some threshold] if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (CS%area_shelf_h(i,j) > 0.0) .and. & + (ISS%area_shelf_h(i,j) > 0.0) .and. & (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then if (CS%threeeq) then @@ -541,11 +385,10 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) Sbdry(i,j) = MAX(Sbdry1, Sbdry2) ! Safety check if (Sbdry(i,j) < 0.) then - write(*,*)'state%sss(i,j)',state%sss(i,j) - write(*,*)'S_a, S_b, S_c',S_a, S_b, S_c - write(*,*)'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 - call MOM_error(FATAL, & - "shelf_calc_flux: Negative salinity (Sbdry).") + write(*,*)'state%sss(i,j)',state%sss(i,j) + write(*,*)'S_a, S_b, S_c',S_a, S_b, S_c + write(*,*)'I,J,Sbdry1,Sbdry2',i,j,Sbdry1,Sbdry2 + call MOM_error(FATAL, "shelf_calc_flux: Negative salinity (Sbdry).") endif else ! Guess sss as the iteration starting point for the boundary salinity. @@ -555,9 +398,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) do it1 = 1,20 ! Determine the potential temperature at the ice-ocean interface. - call calculate_TFreeze(Sbdry(i,j), p_int(i), CS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(Sbdry(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - dT_ustar = (state%sst(i,j) - CS%tfreeze(i,j)) * ustar_h + dT_ustar = (state%sst(i,j) - ISS%tfreeze(i,j)) * ustar_h dS_ustar = (state%sss(i,j) - Sbdry(i,j)) * ustar_h ! First, determine the buoyancy flux assuming no effects of stability @@ -565,13 +408,13 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! when the buoyancy flux is destabilizing. if (CS%const_gamma) then ! if using a constant gamma_T - ! note the different form, here I_Gam_T is NOT 1/Gam_T! - I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_T_3EQ/35. + ! note the different form, here I_Gam_T is NOT 1/Gam_T! + I_Gam_T = CS%Gamma_T_3EQ + I_Gam_S = CS%Gamma_T_3EQ/35. else - Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) - I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) - I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) + Gam_turb = I_VK * (ln_neut + (0.5 * I_ZETA_N - 1.0)) + I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) + I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) endif wT_flux = dT_ustar * I_Gam_T @@ -600,9 +443,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif if (CS%const_gamma) then ! if using a constant gamma_T - ! note the different form, here I_Gam_T is NOT 1/Gam_T! - I_Gam_T = CS%Gamma_T_3EQ - I_Gam_S = CS%Gamma_T_3EQ/35. + ! note the different form, here I_Gam_T is NOT 1/Gam_T! + I_Gam_T = CS%Gamma_T_3EQ + I_Gam_S = CS%Gamma_T_3EQ/35. else I_Gam_T = 1.0 / (Gam_mol_t + Gam_turb) I_Gam_S = 1.0 / (Gam_mol_s + Gam_turb) @@ -624,9 +467,9 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) enddo !it3 endif - CS%t_flux(i,j) = RhoCp * wT_flux - CS%exch_vel_t(i,j) = ustar_h * I_Gam_T - CS%exch_vel_s(i,j) = ustar_h * I_Gam_S + ISS%tflux_ocn(i,j) = RhoCp * wT_flux + exch_vel_t(i,j) = ustar_h * I_Gam_T + exch_vel_s(i,j) = ustar_h * I_Gam_S !Calculate the heat flux inside the ice shelf. @@ -636,39 +479,39 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! dT/dz ~= min( (lprec/(rho_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) !If this approximation is not made, iterations are required... See H+J Fig 3. - if (CS%t_flux(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. - CS%lprec(i,j) = I_LF * CS%t_flux(i,j) - CS%tflux_shelf(i,j) = 0.0 + if (ISS%tflux_ocn(i,j) <= 0.0) then ! Freezing occurs, so zero ice heat flux. + ISS%water_flux(i,j) = I_LF * ISS%tflux_ocn(i,j) + ISS%tflux_shelf(i,j) = 0.0 else if (CS%insulator) then - !no conduction/perfect insulator - CS%tflux_shelf(i,j) = 0.0 - CS%lprec(i,j) = I_LF * (- CS%tflux_shelf(i,j) + CS%t_flux(i,j)) + !no conduction/perfect insulator + ISS%tflux_shelf(i,j) = 0.0 + ISS%water_flux(i,j) = I_LF * (- ISS%tflux_shelf(i,j) + ISS%tflux_ocn(i,j)) else - ! With melting, from H&J 1999, eqs (31) & (26)... - ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec - ! RhoLF*lprec = Q_ice + CS%t_flux(i,j) - ! lprec = (CS%t_flux(i,j)) / (LF + cp_ice * (T_freeze-CS%Temp_Ice)) - CS%lprec(i,j) = CS%t_flux(i,j) / & - (LF + CS%CP_Ice * (CS%Tfreeze(i,j) - CS%Temp_Ice)) - - CS%tflux_shelf(i,j) = CS%t_flux(i,j) - LF*CS%lprec(i,j) + ! With melting, from H&J 1999, eqs (31) & (26)... + ! Q_ice ~= cp_ice * (CS%Temp_Ice-T_freeze) * lprec + ! RhoLF*lprec = Q_ice + ISS%tflux_ocn(i,j) + ! lprec = (ISS%tflux_ocn(i,j)) / (LF + cp_ice * (T_freeze-CS%Temp_Ice)) + ISS%water_flux(i,j) = ISS%tflux_ocn(i,j) / & + (LF + CS%CP_Ice * (ISS%tfreeze(i,j) - CS%Temp_Ice)) + + ISS%tflux_shelf(i,j) = ISS%tflux_ocn(i,j) - LF*ISS%water_flux(i,j) endif endif !other options: dTi/dz linear through shelf - ! dTi_dz = (CS%Temp_Ice - CS%tfreeze(i,j))/G%draft(i,j) - ! CS%tflux_shelf(i,j) = - Rho_Ice * CS%CP_Ice * KTI * dTi_dz + ! dTi_dz = (CS%Temp_Ice - ISS%tfreeze(i,j))/G%draft(i,j) + ! ISS%tflux_shelf(i,j) = - Rho_Ice * CS%CP_Ice * KTI * dTi_dz if (CS%find_salt_root) then exit ! no need to do interaction, so exit loop else - mass_exch = CS%exch_vel_s(i,j) * CS%Rho0 + mass_exch = exch_vel_s(i,j) * CS%Rho0 Sbdry_it = (state%sss(i,j) * mass_exch + CS%Salin_ice * & - CS%lprec(i,j)) / (mass_exch + CS%lprec(i,j)) + ISS%water_flux(i,j)) / (mass_exch + ISS%water_flux(i,j)) dS_it = Sbdry_it - Sbdry(i,j) if (abs(dS_it) < 1e-4*(0.5*(state%sss(i,j) + Sbdry(i,j) + 1.e-10))) exit @@ -685,11 +528,11 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) endif ! dS_it < 0.0 if (Sb_min_set .and. Sb_max_set) then - ! Use the false position method for the next iteration. - Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * & - (dS_min / (dS_min - dS_max)) + ! Use the false position method for the next iteration. + Sbdry(i,j) = Sb_min + (Sb_max-Sb_min) * & + (dS_min / (dS_min - dS_max)) else - Sbdry(i,j) = Sbdry_it + Sbdry(i,j) = Sbdry_it endif ! Sb_min_set Sbdry(i,j) = Sbdry_it @@ -703,16 +546,16 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) ! is specified and large enough that the ocean salinity at the interface ! is about the same as the boundary layer salinity. - call calculate_TFreeze(state%sss(i,j), p_int(i), CS%tfreeze(i,j), CS%eqn_of_state) + call calculate_TFreeze(state%sss(i,j), p_int(i), ISS%tfreeze(i,j), CS%eqn_of_state) - CS%exch_vel_t(i,j) = CS%gamma_t - CS%t_flux(i,j) = RhoCp * CS%exch_vel_t(i,j) * (state%sst(i,j) - CS%tfreeze(i,j)) - CS%tflux_shelf(i,j) = 0.0 - CS%lprec(i,j) = I_LF * CS%t_flux(i,j) + exch_vel_t(i,j) = CS%gamma_t + ISS%tflux_ocn(i,j) = RhoCp * exch_vel_t(i,j) * (state%sst(i,j) - ISS%tfreeze(i,j)) + ISS%tflux_shelf(i,j) = 0.0 + ISS%water_flux(i,j) = I_LF * ISS%tflux_ocn(i,j) Sbdry(i,j) = 0.0 endif else !not shelf - CS%t_flux(i,j) = 0.0 + ISS%tflux_ocn(i,j) = 0.0 endif ! haline_driving(:,:) = state%sss(i,j) - Sbdry(i,j) @@ -720,214 +563,281 @@ subroutine shelf_calc_flux(state, forces, fluxes, Time, time_step, CS) enddo ! i-loop enddo ! j-loop - ! CS%lprec = precipitating liquid water into the ocean ( kg/(m^2 s) ) + ! ISS%water_flux = net liquid water into the ocean ( kg/(m^2 s) ) ! We want melt in m/year if (CS%const_gamma) then ! use ISOMIP+ eq. with rho_fw - fluxes%iceshelf_melt = CS%lprec * (86400.0*365.0/rho_fw) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/rho_fw) * CS%flux_factor else ! use original eq. - fluxes%iceshelf_melt = CS%lprec * (86400.0*365.0/CS%density_ice) * CS%flux_factor + fluxes%iceshelf_melt = ISS%water_flux * (86400.0*365.0/CS%density_ice) * CS%flux_factor endif - do j=js,je - do i=is,ie - if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & - (CS%area_shelf_h(i,j) > 0.0) .and. & - (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then - - ! Set melt to zero above a cutoff pressure - ! (CS%Rho0*CS%cutoff_depth*CS%g_Earth) this is needed for the isomip - ! test case. - if ((CS%g_Earth * CS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & - CS%g_Earth) then - CS%lprec(i,j) = 0.0 - fluxes%iceshelf_melt(i,j) = 0.0 - endif - ! Compute haline driving, which is one of the diags. used in ISOMIP - haline_driving(i,j) = (CS%lprec(i,j) * Sbdry(i,j)) / & - (CS%Rho0 * CS%exch_vel_s(i,j)) - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! - !1)Check if haline_driving computed above is consistent with - ! haline_driving = state%sss - Sbdry - !if (fluxes%iceshelf_melt(i,j) /= 0.0) then - ! if (haline_driving(i,j) /= (state%sss(i,j) - Sbdry(i,j))) then - ! write(*,*)'Something is wrong at i,j',i,j - ! write(*,*)'haline_driving, sss-Sbdry',haline_driving(i,j), & - ! (state%sss(i,j) - Sbdry(i,j)) - ! call MOM_error(FATAL, & - ! "shelf_calc_flux: Inconsistency in melt and haline_driving") - ! endif - !endif - - ! 2) check if |melt| > 0 when star_shelf = 0. - ! this should never happen - if (abs(fluxes%iceshelf_melt(i,j))>0.0) then - if (fluxes%ustar_shelf(i,j) == 0.0) then - write(*,*)'Something is wrong at i,j',i,j - call MOM_error(FATAL, & - "shelf_calc_flux: |melt| > 0 and star_shelf = 0.") - endif - endif - endif ! area_shelf_h - !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! - enddo ! i-loop - enddo ! j-loop + do j=js,je ; do i=is,ie + if ((iDens*state%ocean_mass(i,j) > CS%col_thick_melt_threshold) .and. & + (ISS%area_shelf_h(i,j) > 0.0) .and. & + (CS%isthermo) .and. (state%Hml(i,j) > 0.0) ) then + + ! Set melt to zero above a cutoff pressure + ! (CS%Rho0*CS%cutoff_depth*CS%g_Earth) this is needed for the isomip + ! test case. + if ((CS%g_Earth * ISS%mass_shelf(i,j)) < CS%Rho0*CS%cutoff_depth* & + CS%g_Earth) then + ISS%water_flux(i,j) = 0.0 + fluxes%iceshelf_melt(i,j) = 0.0 + endif + ! Compute haline driving, which is one of the diags. used in ISOMIP + haline_driving(i,j) = (ISS%water_flux(i,j) * Sbdry(i,j)) / & + (CS%Rho0 * exch_vel_s(i,j)) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!Safety checks !!!!!!!!!!!!!!!!!!!!!!!!! + !1)Check if haline_driving computed above is consistent with + ! haline_driving = state%sss - Sbdry + !if (fluxes%iceshelf_melt(i,j) /= 0.0) then + ! if (haline_driving(i,j) /= (state%sss(i,j) - Sbdry(i,j))) then + ! write(*,*)'Something is wrong at i,j',i,j + ! write(*,*)'haline_driving, sss-Sbdry',haline_driving(i,j), & + ! (state%sss(i,j) - Sbdry(i,j)) + ! call MOM_error(FATAL, & + ! "shelf_calc_flux: Inconsistency in melt and haline_driving") + ! endif + !endif + + ! 2) check if |melt| > 0 when star_shelf = 0. + ! this should never happen + if ((abs(fluxes%iceshelf_melt(i,j))>0.0) .and. (fluxes%ustar_shelf(i,j) == 0.0)) then + write(*,*)'Something is wrong at i,j',i,j + call MOM_error(FATAL, & + "shelf_calc_flux: |melt| > 0 and star_shelf = 0.") + endif + endif ! area_shelf_h + !!!!!!!!!!!!!!!!!!!!!!!!!!!!End of safety checks !!!!!!!!!!!!!!!!!!! + enddo ; enddo ! i- and j-loops ! mass flux (kg/s), part of ISOMIP diags. - ALLOCATE ( mass_flux(G%ied,G%jed) ); mass_flux(:,:) = 0.0 - mass_flux = (CS%lprec) * CS%area_shelf_h + mass_flux(:,:) = 0.0 + mass_flux(:,:) = ISS%water_flux(:,:) * ISS%area_shelf_h(:,:) - if (CS%shelf_mass_is_dynamic) then + if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then call cpu_clock_begin(id_clock_pass) - call pass_var(CS%area_shelf_h, G%domain, complete=.false.) - call pass_var(CS%mass_shelf, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain) call cpu_clock_end(id_clock_pass) endif ! Melting has been computed, now is time to update thickness and mass - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement) then - if (.not. (CS%mass_from_file)) then + if ( CS%override_shelf_movement .and. (.not.CS%mass_from_file)) then + call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice, CS%debug) + endif - call change_thickness_using_melt(CS,G,time_step, fluxes) + if (CS%DEBUG) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, haloshift=0) - endif + call add_shelf_flux(G, CS, state, fluxes) + + ! now the thermodynamic data is passed on... time to update the ice dynamic quantities + + if (CS%active_shelf_dynamics) then + update_ice_vel = .false. + coupled_GL = (CS%GL_couple .and. .not.CS%solo_ice_sheet) + + ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. + ! when we decide on how to do it + call update_ice_shelf(CS%dCS, ISS, G, time_step, Time, state%ocean_mass, coupled_GL) endif - if (CS%DEBUG) then - call MOM_forcing_chksum("Before add shelf flux", fluxes, G, haloshift=0) + call enable_averaging(time_step,Time,CS%diag) + 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_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, (state%sst-ISS%tfreeze), CS%diag) + if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) + if (CS%id_haline_driving > 0) call post_data(CS%id_haline_driving, haline_driving, CS%diag) + if (CS%id_mass_flux > 0) call post_data(CS%id_mass_flux, mass_flux, CS%diag) + if (CS%id_u_ml > 0) call post_data(CS%id_u_ml, state%u, CS%diag) + if (CS%id_v_ml > 0) call post_data(CS%id_v_ml, state%v, CS%diag) + if (CS%id_tfreeze > 0) call post_data(CS%id_tfreeze, ISS%tfreeze, CS%diag) + if (CS%id_tfl_shelf > 0) call post_data(CS%id_tfl_shelf, ISS%tflux_shelf, CS%diag) + if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, exch_vel_t, CS%diag) + if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, exch_vel_s, CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,ISS%h_shelf,CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) + call disable_averaging(CS%diag) + + if (present(forces)) then + call add_shelf_forces(G, CS, forces, do_shelf_area=(CS%active_shelf_dynamics .or. & + CS%override_shelf_movement)) endif - call add_shelf_flux(G, CS, state, forces, fluxes) - ! now the thermodynamic data is passed on... time to update the ice dynamic quantities + call cpu_clock_end(id_clock_shelf) - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then + if (CS%DEBUG) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, haloshift=0) - ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. - ! when we decide on how to do it +end subroutine shelf_calc_flux - ! note time_step is [s] and lprec is [kg / m^2 / s] +!> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting +subroutine change_thickness_using_melt(ISS, G, time_step, fluxes, rho_ice, debug) + 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 + real, intent(in) :: time_step !< The time step for this update, in s. + type(forcing), intent(inout) :: fluxes !< structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + real, intent(in) :: rho_ice !< The density of ice-shelf ice, in kg m-3. + logical, optional, intent(in) :: debug !< If present and true, write chksums - call ice_shelf_advect (CS, time_step, CS%lprec, Time) + ! locals + real :: I_rho_ice + integer :: i, j - CS%velocity_update_sub_counter = CS%velocity_update_sub_counter+1 + I_rho_ice = 1.0 / rho_ice - if (CS%GL_couple .and. .not. CS%solo_ice_sheet) then - call update_OD_ffrac (CS, state%ocean_mass, CS%velocity_update_sub_counter, CS%nstep_velocity, CS%time_step, CS%velocity_update_time_step) - else - call update_OD_ffrac_uncoupled (CS) + 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 + ! first, zero out fluxes applied during previous time step + if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 + if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 + if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 + if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 + + if (ISS%water_flux(i,j) / rho_ice * time_step < ISS%h_shelf(i,j)) then + ISS%h_shelf(i,j) = ISS%h_shelf(i,j) - ISS%water_flux(i,j) / rho_ice * time_step + else + ! the ice is about to melt away, 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 endif + enddo ; enddo - if (CS%velocity_update_sub_counter .eq. CS%nstep_velocity) then + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) - if (is_root_pe()) write(*,*) "ABOUT TO CALL VELOCITY SOLVER" + !### combine this with the loops above. + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*rho_ice + endif + enddo ; enddo - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, 1, iters_vel_solve, Time) + call pass_var(ISS%mass_shelf, G%domain) - CS%velocity_update_sub_counter = 0 + if (present(debug)) then ; if (debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0) + endif ; endif - endif - endif +end subroutine change_thickness_using_melt - call enable_averaging(time_step,Time,CS%diag) - if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, CS%mass_shelf, CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, CS%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_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, (state%sst-CS%tfreeze), CS%diag) - if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) - if (CS%id_haline_driving > 0) call post_data(CS%id_haline_driving, haline_driving, CS%diag) - if (CS%id_mass_flux > 0) call post_data(CS%id_mass_flux, mass_flux, CS%diag) - if (CS%id_u_ml > 0) call post_data(CS%id_u_ml,state%u,CS%diag) - if (CS%id_v_ml > 0) call post_data(CS%id_v_ml,state%v,CS%diag) - if (CS%id_tfreeze > 0) call post_data(CS%id_tfreeze, CS%tfreeze, CS%diag) - if (CS%id_tfl_shelf > 0) call post_data(CS%id_tfl_shelf, CS%tflux_shelf, CS%diag) - if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, CS%exch_vel_t, CS%diag) - if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, CS%exch_vel_s, CS%diag) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,CS%h_shelf,CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,CS%hmask,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_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,CS%float_frac_rt,CS%diag) - call disable_averaging(CS%diag) +!> This subroutine adds the mechanical forcing fields and perhaps shelf areas, based on +!! the ice state in ice_shelf_CS. +subroutine add_shelf_forces(G, CS, forces, do_shelf_area) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), pointer :: CS !< This module's control structure. + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + logical, optional, intent(in) :: do_shelf_area !< If true find the shelf-covered areas. - call cpu_clock_end(id_clock_shelf) + real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. + real :: press_ice ! The pressure of the ice shelf per unit area of ocean (not ice) in Pa. + logical :: find_area ! If true find the shelf areas at u & v points. + type(ice_shelf_state), pointer :: ISS => NULL() ! A structure with elements that describe + ! the ice-shelf state - if (CS%DEBUG) then - call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, haloshift=0) + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + ISS => CS%ISS + + find_area = .true. ; if (present(do_shelf_area)) find_area = do_shelf_area + + if (find_area) then + ! The frac_shelf is set over the widest possible area. Could it be smaller? + do j=jsd,jed ; do I=isd,ied-1 + forces%frac_shelf_u(I,j) = 0.0 + if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%areaCu(I,j) > 0.0)) & + forces%frac_shelf_u(I,j) = ((ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) / & + (G%areaT(i,j) + G%areaT(i+1,j))) + enddo ; enddo + do J=jsd,jed-1 ; do i=isd,ied + forces%frac_shelf_v(i,J) = 0.0 + if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%areaCv(i,J) > 0.0)) & + forces%frac_shelf_v(i,J) = ((ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) / & + (G%areaT(i,j) + G%areaT(i,j+1))) + enddo ; enddo + call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) endif -end subroutine shelf_calc_flux + !### Consider working over a smaller array range. + do j=jsd,jed ; do i=isd,ied + press_ice = (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * ISS%mass_shelf(i,j)) + if (associated(forces%p_surf)) then + if (.not.forces%accumulate_p_surf) forces%p_surf(i,j) = 0.0 + forces%p_surf(i,j) = forces%p_surf(i,j) + press_ice + endif + if (associated(forces%p_surf_full)) then + if (.not.forces%accumulate_p_surf) forces%p_surf_full(i,j) = 0.0 + forces%p_surf_full(i,j) = forces%p_surf_full(i,j) + press_ice + endif + enddo ; enddo -!> Changes the thickness (mass) of the ice shelf based on sub-ice-shelf melting -subroutine change_thickness_using_melt(CS,G,time_step, fluxes) - type(ocean_grid_type), intent(inout) :: G - type(ice_shelf_CS), intent(inout) :: CS - real, intent(in) :: time_step - type(forcing), intent(inout) :: fluxes + ! For various reasons, forces%rigidity_ice_[uv] is always updated here. Note + ! that it may have been zeroed out where IOB is translated to forces and + ! contributions from icebergs and the sea-ice pack added subsequently. + !### THE RIGIDITY SHOULD ALSO INCORPORATE AREAL-COVERAGE INFORMATION. + kv_rho_ice = CS%kv_ice / CS%density_ice + do j=js,je ; do I=is-1,ie + if (.not.forces%accumulate_rigidity) forces%rigidity_ice_u(I,j) = 0.0 + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + & + kv_rho_ice * min(ISS%mass_shelf(i,j), ISS%mass_shelf(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + if (.not.forces%accumulate_rigidity) forces%rigidity_ice_v(i,J) = 0.0 + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + & + kv_rho_ice * min(ISS%mass_shelf(i,j), ISS%mass_shelf(i,j+1)) + enddo ; enddo - ! locals - integer :: i, j + if (CS%debug) then + call uvchksum("rigidity_ice_[uv]", forces%rigidity_ice_u, forces%rigidity_ice_v, & + G%HI, symmetric=.true.) + call uvchksum("frac_shelf_[uv]", forces%frac_shelf_u, forces%frac_shelf_v, & + G%HI, symmetric=.true.) + endif - do j=G%jsc,G%jec - do i=G%isc,G%iec +end subroutine add_shelf_forces - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - ! first, zero out fluxes applied during previous time step - if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 - if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 - if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 - if (associated(fluxes%p_surf)) fluxes%p_surf(i,j) = 0.0 - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 +!> This subroutine adds the ice shelf pressure to the fluxes type. +subroutine add_shelf_pressure(G, CS, fluxes) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), intent(in) :: CS !< This module's control structure. + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be updated. - if (CS%lprec(i,j) / CS%density_ice * time_step .lt. CS%h_shelf (i,j)) then - CS%h_shelf (i,j) = CS%h_shelf (i,j) - CS%lprec(i,j) / CS%density_ice * time_step - else - ! the ice is about to melt away - ! in this case set thickness, area, and mask to zero - ! NOTE: not mass conservative - ! should maybe scale salt & heat flux for this cell - - CS%h_shelf(i,j) = 0.0 - CS%hmask(i,j) = 0.0 - CS%area_shelf_h(i,j) = 0.0 - endif - endif - enddo - enddo - - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%hmask, G%domain) - - do j=G%jsd,G%jed - do i=G%isd,G%ied - - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice - endif - enddo - enddo - - call pass_var(CS%mass_shelf, G%domain) + real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) in Pa. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (CS%DEBUG) then - call hchksum (CS%h_shelf, "h_shelf after change thickness using melt", G%HI, haloshift=0) - call hchksum (CS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0) + do j=js,je ; do i=is,ie + press_ice = (CS%ISS%area_shelf_h(i,j) * G%IareaT(i,j)) * (CS%g_Earth * CS%ISS%mass_shelf(i,j)) + if (associated(fluxes%p_surf)) then + if (.not.fluxes%accumulate_p_surf) fluxes%p_surf(i,j) = 0.0 + fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + press_ice endif + if (associated(fluxes%p_surf_full)) then + if (.not.fluxes%accumulate_p_surf) fluxes%p_surf_full(i,j) = 0.0 + fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + press_ice + endif + enddo ; enddo -end subroutine change_thickness_using_melt +end subroutine add_shelf_pressure -!> Updates suface fluxes that are influenced by sub-ice-shelf melting -subroutine add_shelf_flux(G, CS, state, forces, fluxes) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - type(ice_shelf_CS), pointer :: CS !< This module's control structure. - type(surface), intent(inout) :: state!< Surface ocean state - type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces - type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. +!> Updates surface fluxes that are influenced by sub-ice-shelf melting +subroutine add_shelf_flux(G, CS, state, fluxes) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), pointer :: CS !< This module's control structure. + type(surface), intent(inout) :: state!< Surface ocean state + type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. ! local variables real :: Irho0 !< The inverse of the mean density in m3 kg-1. @@ -936,6 +846,7 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) real :: shelf_mass1 !< Total ice shelf mass at current time (Time). real :: delta_mass_shelf!< Change in ice shelf mass over one time step in kg/s real :: taux2, tauy2 !< The squared surface stresses, in Pa. + real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) in Pa. real :: asu1, asu2 !< Ocean areas covered by ice shelves at neighboring u- real :: asv1, asv2 !< and v-points, in m2. real :: fraz !< refreezing rate in kg m-2 s-1 @@ -943,130 +854,92 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) real :: sponge_area !< total area of sponge region real :: t0 !< The previous time (Time-dt) in sec. type(time_type) :: Time0!< The previous time (Time-dt) - real, dimension(:,:), allocatable, target :: last_mass_shelf !< Ice shelf mass - ! at at previous time (Time-dt), in kg/m^2 - real, dimension(:,:), allocatable, target :: last_h_shelf !< Ice shelf thickness - ! at at previous time (Time-dt), in m - real, dimension(:,:), allocatable, target :: last_hmask !< Ice shelf mask - ! at at previous time (Time-dt) - real, dimension(:,:), allocatable, target :: last_area_shelf_h !< Ice shelf area - ! at at previous time (Time-dt), m^2 - + real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass + !! at at previous time (Time-dt), in kg/m^2 + real, dimension(SZDI_(G),SZDJ_(G)) :: last_h_shelf !< Ice shelf thickness + !! at at previous time (Time-dt), in m + real, dimension(SZDI_(G),SZDJ_(G)) :: last_hmask !< Ice shelf mask + !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area + !! at at previous time (Time-dt), m^2 + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + + real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. real, parameter :: rho_fw = 1000.0 ! fresh water density integer :: i, j, is, ie, js, je, isd, ied, jsd, jed is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - Irho0 = 1.0 / CS%Rho0 + ISS => CS%ISS + + call add_shelf_pressure(G, CS, fluxes) + ! Determine ustar and the square magnitude of the velocity in the ! bottom boundary layer. Together these give the TKE source and ! vertical decay scale. - if (CS%shelf_mass_is_dynamic) then - do j=jsd,jed ; do i=isd,ied - if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) - enddo ; enddo - !do I=isd,ied-1 ; do j=isd,jed - do j=jsd,jed ; do i=isd,ied-1 ! ### changed stride order; i->ied-1? - forces%frac_shelf_u(I,j) = 0.0 - if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i+1,j)) / & - (G%areaT(i,j) + G%areaT(i+1,j))) - !### Either the min here or the max below must be wrong, but is either right? -RWH - forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & - min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) - enddo ; enddo - do j=jsd,jed-1 ; do i=isd,ied ! ### change stride order; j->jed-1? - !do i=isd,ied ; do J=isd,jed-1 - forces%frac_shelf_v(i,J) = 0.0 - if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i,j+1)) / & - (G%areaT(i,j) + G%areaT(i,j+1))) - !### Either the max here or the min above must be wrong, but is either right? -RWH - forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & - max(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) - enddo ; enddo - call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) - else - ! This is needed because rigidity is potentially modified in the coupler. Reset - ! in the ice shelf cavity: MJH - - do j=jsd,jed ; do i=isd,ied-1 ! changed stride - forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & - min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) - enddo ; enddo - - do j=jsd,jed-1 ; do i=isd,ied ! changed stride - forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & - max(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) - enddo ; enddo - endif if (CS%debug) then - if (associated(state%taux_shelf)) then - call uchksum(state%taux_shelf, "taux_shelf", G%HI, haloshift=0) - endif - if (associated(state%tauy_shelf)) then - call vchksum(state%tauy_shelf, "tauy_shelf", G%HI, haloshift=0) - call vchksum(forces%rigidity_ice_u, "rigidity_ice_u", G%HI, haloshift=0) - call vchksum(forces%rigidity_ice_v, "rigidity_ice_v", G%HI, haloshift=0) - call vchksum(forces%frac_shelf_u, "frac_shelf_u", G%HI, haloshift=0) - call vchksum(forces%frac_shelf_v, "frac_shelf_v", G%HI, haloshift=0) + if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then + call uvchksum("tau[xy]_shelf", state%taux_shelf, state%tauy_shelf, & + G%HI, haloshift=0) endif endif if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) endif + ! GMM: melting is computed using ustar_shelf (and not ustar), which has already + ! been passed, I so believe we do not need to update fluxes%ustar. +! Irho0 = 1.0 / CS%Rho0 +! do j=js,je ; do i=is,ie ; if (fluxes%frac_shelf_h(i,j) > 0.0) then + ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. + ! taux2 = 0.0 ; tauy2 = 0.0 + ! asu1 = (ISS%area_shelf_h(i-1,j) + ISS%area_shelf_h(i,j)) + ! asu2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i+1,j)) + ! asv1 = (ISS%area_shelf_h(i,j-1) + ISS%area_shelf_h(i,j)) + ! asv2 = (ISS%area_shelf_h(i,j) + ISS%area_shelf_h(i,j+1)) + ! if ((asu1 + asu2 > 0.0) .and. associated(state%taux_shelf)) & + ! taux2 = (asu1 * state%taux_shelf(I-1,j)**2 + & + ! asu2 * state%taux_shelf(I,j)**2 ) / (asu1 + asu2) + ! if ((asv1 + asv2 > 0.0) .and. associated(state%tauy_shelf)) & + ! tauy2 = (asv1 * state%tauy_shelf(i,J-1)**2 + & + ! asv2 * state%tauy_shelf(i,J)**2 ) / (asv1 + asv2) + + !fluxes%ustar(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) +! endif ; enddo ; enddo + + if (CS%active_shelf_dynamics .or. CS%override_shelf_movement) then + do j=jsd,jed ; do i=isd,ied + if (G%areaT(i,j) > 0.0) & + fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) * G%IareaT(i,j) + enddo ; enddo + endif - if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir = 0.0 - if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif = 0.0 - if (associated(fluxes%sw_nir_dir)) fluxes%sw_nir_dir = 0.0 - if (associated(fluxes%sw_nir_dif)) fluxes%sw_nir_dif = 0.0 - - do j=G%jsc,G%jec ; do i=G%isc,G%iec - frac_area = fluxes%frac_shelf_h(i,j) - if (frac_area > 0.0) then - ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. - taux2 = 0.0 ; tauy2 = 0.0 - asu1 = forces%frac_shelf_u(i-1,j) * (G%areaT(i-1,j) + G%areaT(i,j)) ! G%dxdy_u(i-1,j) - asu2 = forces%frac_shelf_u(i,j) * (G%areaT(i,j) + G%areaT(i+1,j)) ! G%dxdy_u(i,j) - asv1 = forces%frac_shelf_v(i,j-1) * (G%areaT(i,j-1) + G%areaT(i,j)) ! G%dxdy_v(i,j-1) - asv2 = forces%frac_shelf_v(i,j) * (G%areaT(i,j) + G%areaT(i,j+1)) ! G%dxdy_v(i,j) - if ((asu1 + asu2 > 0.0) .and. associated(state%taux_shelf)) & - taux2 = (asu1 * state%taux_shelf(i-1,j)**2 + & - asu2 * state%taux_shelf(i,j)**2 ) / (asu1 + asu2) - if ((asv1 + asv2 > 0.0) .and. associated(state%tauy_shelf)) & - tauy2 = (asv1 * state%tauy_shelf(i,j-1)**2 + & - asv2 * state%tauy_shelf(i,j)**2 ) / (asv1 + asv2) - - ! GMM: melting is computed using ustar_shelf (and not ustar), which has already - ! been passed, so believe we do not need to update fluxes%ustar. - !fluxes%ustar(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) - - if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 - if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 - if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 - if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 - if (associated(fluxes%lprec)) then - if (CS%lprec(i,j) > 0.0 ) then - fluxes%lprec(i,j) = frac_area*CS%lprec(i,j)*CS%flux_factor - else - fluxes%lprec(i,j) = 0.0 - fluxes%evap(i,j) = frac_area*CS%lprec(i,j)*CS%flux_factor - endif + do j=js,je ; do i=is,ie ; if (ISS%area_shelf_h(i,j) > 0.0) then + frac_area = fluxes%frac_shelf_h(i,j) !### Should this be 1-frac_shelf_h? + if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 + if (associated(fluxes%sw_vis_dir)) fluxes%sw_vis_dir(i,j) = 0.0 + if (associated(fluxes%sw_vis_dif)) fluxes%sw_vis_dif(i,j) = 0.0 + if (associated(fluxes%sw_nir_dir)) fluxes%sw_nir_dir(i,j) = 0.0 + if (associated(fluxes%sw_nir_dif)) fluxes%sw_nir_dif(i,j) = 0.0 + if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 + if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 + if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 + if (associated(fluxes%lprec)) then + if (ISS%water_flux(i,j) > 0.0) then + fluxes%lprec(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor + else + fluxes%lprec(i,j) = 0.0 + fluxes%evap(i,j) = frac_area*ISS%water_flux(i,j)*CS%flux_factor endif - - - if (associated(fluxes%sens)) fluxes%sens(i,j) = -frac_area*CS%t_flux(i,j)*CS%flux_factor - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = frac_area * CS%salt_flux(i,j)*CS%flux_factor - if (associated(fluxes%p_surf)) fluxes%p_surf(i,j) = frac_area * CS%g_Earth * CS%mass_shelf(i,j) - ! Same for IOB%p - if (associated(fluxes%p_surf_full) ) fluxes%p_surf_full(i,j) = & - frac_area * CS%g_Earth * CS%mass_shelf(i,j) - endif - enddo ; enddo + + if (associated(fluxes%sens)) & + fluxes%sens(i,j) = -frac_area*ISS%tflux_ocn(i,j)*CS%flux_factor + if (associated(fluxes%salt_flux)) & + fluxes%salt_flux(i,j) = frac_area * ISS%salt_flux(i,j)*CS%flux_factor + endif ; enddo ; enddo ! keep sea level constant by removing mass in the sponge ! region (via virtual precip, vprec). Apply additional @@ -1075,126 +948,110 @@ subroutine add_shelf_flux(G, CS, state, forces, fluxes) ! This is needed for some of the ISOMIP+ experiments. if (CS%constant_sea_level) then + !### This code has lots of problems with hard coded constants and the use of + !### of non-reproducing sums. It needs to be refactored. -RWH if (.not. associated(fluxes%salt_flux)) allocate(fluxes%salt_flux(ie,je)) if (.not. associated(fluxes%vprec)) allocate(fluxes%vprec(ie,je)) - fluxes%salt_flux(:,:) = 0.0; fluxes%vprec(:,:) = 0.0 + fluxes%salt_flux(:,:) = 0.0 ; fluxes%vprec(:,:) = 0.0 mean_melt_flux = 0.0; sponge_area = 0.0 do j=js,je ; do i=is,ie - frac_area = fluxes%frac_shelf_h(i,j) - if (frac_area > 0.0) then - mean_melt_flux = mean_melt_flux + (CS%lprec(i,j)) * CS%area_shelf_h(i,j) - endif + frac_area = fluxes%frac_shelf_h(i,j) + if (frac_area > 0.0) & + mean_melt_flux = mean_melt_flux + (ISS%water_flux(i,j)) * ISS%area_shelf_h(i,j) - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - sponge_area = sponge_area + G%areaT(i,j) - endif - enddo; enddo + !### These hard-coded limits need to be corrected. They are inappropriate here. + if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + sponge_area = sponge_area + G%areaT(i,j) + endif + enddo ; enddo ! take into account changes in mass (or thickness) when imposing ice shelf mass - if (CS%shelf_mass_is_dynamic .and. CS%override_shelf_movement .and. & - CS%mass_from_file) then - t0 = time_type_to_real(CS%Time) - CS%time_step - - ! just compute changes in mass after first time step - if (t0>0.0) then - Time0 = real_to_time_type(t0) - allocate(last_mass_shelf(isd:ied,jsd:jed)) - allocate(last_h_shelf(isd:ied,jsd:jed)) - allocate(last_area_shelf_h(isd:ied,jsd:jed)) - allocate(last_hmask(isd:ied,jsd:jed)) - last_hmask(:,:) = CS%hmask(:,:); last_area_shelf_h(:,:) = CS%area_shelf_h(:,:) - call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) - last_h_shelf = last_mass_shelf/CS%density_ice - - ! apply calving - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS,last_h_shelf,last_area_shelf_h,last_hmask) - ! convert to mass again - last_mass_shelf = last_h_shelf * CS%density_ice - endif - - shelf_mass0 = 0.0; shelf_mass1 = 0.0 - ! get total ice shelf mass at (Time-dt) and (Time), in kg - do j=js,je ; do i=is,ie - ! just floating shelf (0.1 is a threshold for min ocean thickness) - if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & - (CS%area_shelf_h(i,j) > 0.0)) then - - shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * CS%area_shelf_h(i,j)) - shelf_mass1 = shelf_mass1 + (CS%mass_shelf(i,j) * CS%area_shelf_h(i,j)) + if (CS%override_shelf_movement .and. CS%mass_from_file) then + t0 = time_type_to_real(CS%Time) - CS%time_step + + ! just compute changes in mass after first time step + if (t0>0.0) then + Time0 = real_to_time_type(t0) + last_hmask(:,:) = ISS%hmask(:,:) ; last_area_shelf_h(:,:) = ISS%area_shelf_h(:,:) + call time_interp_external(CS%id_read_mass, Time0, last_mass_shelf) + last_h_shelf = last_mass_shelf/CS%density_ice + + ! apply calving + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, last_h_shelf, last_area_shelf_h, last_hmask, & + CS%min_thickness_simple_calve) + ! convert to mass again + last_mass_shelf = last_h_shelf * CS%density_ice + endif - endif - enddo; enddo - call mpp_sum(shelf_mass0); call mpp_sum(shelf_mass1) - delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step + shelf_mass0 = 0.0; shelf_mass1 = 0.0 + ! get total ice shelf mass at (Time-dt) and (Time), in kg + do j=js,je ; do i=is,ie + ! just floating shelf (0.1 is a threshold for min ocean thickness) + if (((1.0/CS%density_ocean_avg)*state%ocean_mass(i,j) > 0.1) .and. & + (ISS%area_shelf_h(i,j) > 0.0)) then + shelf_mass0 = shelf_mass0 + (last_mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + shelf_mass1 = shelf_mass1 + (ISS%mass_shelf(i,j) * ISS%area_shelf_h(i,j)) + endif + enddo ; enddo + call sum_across_PEs(shelf_mass0); call sum_across_PEs(shelf_mass1) + delta_mass_shelf = (shelf_mass1 - shelf_mass0)/CS%time_step ! delta_mass_shelf = (shelf_mass1 - shelf_mass0)* & ! (rho_fw/CS%density_ice)/CS%time_step ! if (is_root_pe()) write(*,*)'delta_mass_shelf',delta_mass_shelf - else! first time step - delta_mass_shelf = 0.0 - endif + else! first time step + delta_mass_shelf = 0.0 + endif else ! ice shelf mass does not change - delta_mass_shelf = 0.0 + delta_mass_shelf = 0.0 endif - call mpp_sum(mean_melt_flux) - call mpp_sum(sponge_area) + call sum_across_PEs(mean_melt_flux) + call sum_across_PEs(sponge_area) ! average total melt flux over sponge area mean_melt_flux = (mean_melt_flux+delta_mass_shelf) / sponge_area !kg/(m^2 s) ! apply fluxes do j=js,je ; do i=is,ie - ! Note the following is hard coded for ISOMIP - if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative - fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 - fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) - endif - enddo; enddo + ! Note the following is hard coded for ISOMIP + if (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then + fluxes%vprec(i,j) = -mean_melt_flux * CS%density_ice/1000. ! evap is negative + fluxes%sens(i,j) = fluxes%vprec(i,j) * CS%Cp * CS%T0 ! W /m^2 + fluxes%salt_flux(i,j) = fluxes%vprec(i,j) * CS%S0*1.0e-3 ! kg (salt)/(m^2 s) + endif + enddo ; enddo if (CS%DEBUG) then - if (is_root_pe()) write(*,*)'Mean melt flux (kg/(m^2 s)),dt',mean_melt_flux,CS%time_step + if (is_root_pe()) write(*,*)'Mean melt flux (kg/(m^2 s)),dt',mean_melt_flux,CS%time_step call MOM_forcing_chksum("After constant sea level", fluxes, G, haloshift=0) - endif - - endif!constant_sea_level - - ! If the shelf mass is changing, the forces%rigidity_ice_[uv] needs to be - ! updated here. - - if (CS%shelf_mass_is_dynamic) then - do j=G%jsc,G%jec ; do i=G%isc-1,G%iec - forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & - max(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) - enddo ; enddo + endif - do j=G%jsc-1,G%jec ; do i=G%isc,G%iec - forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & - max(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) - enddo ; enddo - endif + endif !constant_sea_level end subroutine add_shelf_flux !> Initializes shelf model data, parameters and diagnostics subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fluxes, Time_in, 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 - type(time_type), intent(inout) :: Time - type(ice_shelf_CS), pointer :: CS - type(diag_ctrl), target, intent(in) :: diag - type(forcing), optional, intent(inout) :: fluxes - type(mech_forcing), optional, intent(inout) :: forces - type(time_type), optional, intent(in) :: Time_in - logical, optional, intent(in) :: solo_ice_sheet_in - - type(ocean_grid_type), pointer :: G, OG ! Convenience pointers + 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_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. + type(forcing), optional, intent(inout) :: fluxes !< A structure containing pointers to any possible + !! thermodynamic or mass-flux forcing fields. + type(mech_forcing), optional, intent(inout) :: forces !< A structure with the driving mechanical forces + type(time_type), optional, intent(in) :: Time_in !< The time at initialization. + logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether + !! a solo ice-sheet driver. + + type(ocean_grid_type), pointer :: G => NULL(), OG => NULL() ! Pointers to grids for convenience. + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state type(directories) :: dirs - type(vardesc) :: vd type(dyn_horgrid_type), pointer :: dG => NULL() real :: cdrag, drag_bg_vel logical :: new_sim, save_IC, var_force @@ -1202,12 +1059,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl #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" ! This module's name. - character(len=2) :: procnum - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) - logical :: read_TideAmp + logical :: read_TideAmp, shelf_mass_is_dynamic, debug character(len=240) :: Tideamp_file real :: utide if (associated(CS)) then @@ -1262,30 +1117,32 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl Isdq = G%IsdB ; Iedq = G%IedB ; Jsdq = G%JsdB ; Jedq = G%JedB CS%Lat_fusion = 3.34e5 - CS%override_shelf_movement = .false. - - CS%use_reproducing_sums = .false. - CS%switch_var = .false. + CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "DEBUG_IS", CS%debug, default=.false.) - call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", CS%shelf_mass_is_dynamic, & + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & + "If true, write verbose debugging messages for the ice shelf.", & + default=debug) + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & "If true, the ice sheet mass can evolve with time.", & default=.false.) - if (CS%shelf_mass_is_dynamic) then + if (shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", CS%override_shelf_movement, & "If true, user provided code specifies the ice-shelf \n"//& "movement instead of the dynamic ice model.", default=.false.) + CS%active_shelf_dynamics = .not.CS%override_shelf_movement call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) - call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=0) + "If true, regularize the floatation condition at the \n"//& + "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & - "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) + "If true, let the floatation condition be determined by \n"//& + "ocean column thickness. This means that update_OD_ffrac \n"//& + "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & + default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. - if (CS%GL_regularize .and. (CS%n_sub_regularize.eq.0)) call MOM_error (FATAL, & - "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") endif + call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & "If true, use a thermodynamically interactive ice shelf.", & default=.false.) @@ -1300,7 +1157,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "Depth above which the melt is set to zero (it must be >= 0) \n"//& "Default value won't affect the solution.", default=0.0) if (CS%cutoff_depth < 0.) & - call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") + call MOM_error(WARNING,"Initialize_ice_shelf: MELTING_CUTOFF_DEPTH must be >= 0.") call get_param(param_file, mdl, "CONST_SEA_LEVEL", CS%constant_sea_level, & "If true, apply evaporative, heat and salt fluxes in \n"//& @@ -1400,8 +1257,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl "The time step for changing forcing, coupling with other \n"//& "components, or potentially writing certain diagnostics. \n"//& "The default value is given by DT.", units="s", default=0.0) - call get_param(param_file, mdl, "SHELF_DIAG_TIMESTEP", CS%velocity_update_time_step, & - "A timestep to use for diagnostics of the shelf.", default=0.0) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", CS%col_thick_melt_threshold, & "The minimum ML thickness where melting is allowed.", units="m", & @@ -1426,30 +1281,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0) - CS%utide = utide + CS%utide(:,:) = utide endif call EOS_init(param_file, CS%eqn_of_state) !! new parameters that need to be in MOM_input - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - - call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & - "Ice viscosity parameter in Glen's Law", & - units="Pa -1/3 a", default=9.461e-18) - call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & - "nonlinearity exponent in Glen's Law", & - units="none", default=3.) - call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & - "min. strain rate to avoid infinite Glen's law viscosity", & - units="a-1", default=1.e-12) - call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & - "ceofficient in sliding law \tau_b = C u^(n_basal_friction)", & - units="Pa (m-a)-(n_basal_friction)", fail_if_missing=.true.) - call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_friction, & - "exponent in sliding law \tau_b = C u^(m_slide)", & - units="none", fail_if_missing=.true.) + if (CS%active_shelf_dynamics) then + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0) @@ -1459,55 +1299,16 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "INPUT_THICK_ICE_SHELF", CS%input_thickness, & "flux thickness at upstream boundary", & units="m", default=1000.) - call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & - "seconds between ice velocity calcs", units="s", & - fail_if_missing=.true.) - - call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & - "tolerance in CG solver, relative to initial residual", default=1.e-6) - call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", & - CS%nonlinear_tolerance,"nonlin tolerance in iterative velocity solve",default=1.e-6) - call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & - "max iteratiions in CG solver", default=2000) - call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & - "min ocean thickness to consider ice *floating*; \n"// & - "will only be important with use of tides", & - units="m",default=1.e-3) - - call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & - "whether or not to advance shelf front (and calve..)") - call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & - "if true, do not allow an ice shelf where prohibited by a mask") - call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & - "limit timestep as a factor of min (\Delta x / u); \n"// & - "only important for ice-only model", & - default=0.25) - call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & - "choose whether nonlin error in vel solve is based on nonlinear residual (1) \n"// & - "or relative change since last iteration (2)", & - default=1) - - - if (CS%debug) CS%use_reproducing_sums = .true. - - CS%nstep_velocity = FLOOR (CS%velocity_update_time_step / CS%time_step) - CS%velocity_update_counter = 0 - CS%velocity_update_sub_counter = 0 else - CS%nstep_velocity = 0 ! This is here because of inconsistent defaults. I don't know why. RWH call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=900.0) endif - call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & CS%min_thickness_simple_calve, & - "min thickness rule for VERY simple calving law",& + "Min thickness rule for the very simple calving law",& units="m", default=0.0) - call get_param(param_file, mdl, "WRITE_OUTPUT_TO_FILE", & - CS%write_output_to_file, "for debugging purposes",default=.false.) - call get_param(param_file, mdl, "USTAR_SHELF_BG", CS%ustar_bg, & "The minimum value of ustar under ice sheves.", units="m s-1", & default=0.0) @@ -1526,64 +1327,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl endif - ! Allocate and initialize variables - allocate( CS%mass_shelf(isd:ied,jsd:jed) ) ; CS%mass_shelf(:,:) = 0.0 - allocate( CS%area_shelf_h(isd:ied,jsd:jed) ) ; CS%area_shelf_h(:,:) = 0.0 - allocate( CS%t_flux(isd:ied,jsd:jed) ) ; CS%t_flux(:,:) = 0.0 - allocate( CS%lprec(isd:ied,jsd:jed) ) ; CS%lprec(:,:) = 0.0 - allocate( CS%salt_flux(isd:ied,jsd:jed) ) ; CS%salt_flux(:,:) = 0.0 - - allocate( CS%tflux_shelf(isd:ied,jsd:jed) ) ; CS%tflux_shelf(:,:) = 0.0 - allocate( CS%tfreeze(isd:ied,jsd:jed) ) ; CS%tfreeze(:,:) = 0.0 - allocate( CS%exch_vel_s(isd:ied,jsd:jed) ) ; CS%exch_vel_s(:,:) = 0.0 - allocate( CS%exch_vel_t(isd:ied,jsd:jed) ) ; CS%exch_vel_t(:,:) = 0.0 - - allocate ( CS%h_shelf(isd:ied,jsd:jed) ) ; CS%h_shelf(:,:) = 0.0 - allocate ( CS%hmask(isd:ied,jsd:jed) ) ; CS%hmask(:,:) = -2.0 - - - ! OVS vertically integrated Temperature - allocate ( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 - allocate ( CS%t_boundary_values(isd:ied,jsd:jed) ) ; CS%t_boundary_values(:,:) = -15.0 - allocate ( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - ! DNG - allocate ( CS%u_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_shelf(:,:) = 0.0 - allocate ( CS%v_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_shelf(:,:) = 0.0 - allocate ( CS%u_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_boundary_values(:,:) = 0.0 - allocate ( CS%v_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_boundary_values(:,:) = 0.0 - allocate ( CS%h_boundary_values(isd:ied,jsd:jed) ) ; CS%h_boundary_values(:,:) = 0.0 - allocate ( CS%thickness_boundary_values(isd:ied,jsd:jed) ) ; CS%thickness_boundary_values(:,:) = 0.0 - allocate ( CS%ice_visc_bilinear(isd:ied,jsd:jed) ) ; CS%ice_visc_bilinear(:,:) = 0.0 - allocate ( CS%ice_visc_lower_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_lower_tri = 0.0 - allocate ( CS%ice_visc_upper_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_upper_tri = 0.0 - allocate ( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 - allocate ( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 - allocate ( CS%u_face_mask_boundary(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_boundary(:,:) = -2.0 - allocate ( CS%v_face_mask_boundary(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_boundary(:,:) = -2.0 - allocate ( CS%u_flux_boundary_values(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_boundary_values(:,:) = 0.0 - allocate ( CS%v_flux_boundary_values(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_boundary_values(:,:) = 0.0 - allocate ( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 - allocate ( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 - - allocate ( CS%taub_beta_eff_bilinear(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_bilinear(:,:) = 0.0 - allocate ( CS%taub_beta_eff_upper_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_upper_tri(:,:) = 0.0 - allocate ( CS%taub_beta_eff_lower_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_lower_tri(:,:) = 0.0 - allocate ( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 - allocate ( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 - allocate ( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 0.0 - allocate ( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 - - if (CS%calve_to_mask) then - allocate ( CS%calve_mask (isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 - endif - - endif + ! Allocate and initialize state variables to default values + call ice_shelf_state_init(CS%ISS, CS%grid) + ISS => CS%ISS ! Allocate the arrays for passing ice-shelf data through the forcing type. if (.not. CS%solo_ice_sheet) then - if (is_root_pe()) print *,"initialize_ice_shelf: allocating fluxes" + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes.") ! GMM: the following assures that water/heat fluxes are just allocated ! when SHELF_THERMO = True. These fluxes are necessary if one wants to ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). @@ -1591,10 +1341,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call allocate_forcing_type(G, fluxes, ustar=.true., shelf=.true., & press=.true., water=CS%isthermo, heat=CS%isthermo) if (present(forces)) & - call allocate_mech_forcing(G, forces, ustar=.true., shelf=.true., & - press=.true.) + call allocate_mech_forcing(G, forces, ustar=.true., shelf=.true., press=.true.) else - if (is_root_pe()) print *,"allocating fluxes in solo mode" + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") if (present(fluxes)) & call allocate_forcing_type(G, fluxes, ustar=.true., shelf=.true., press=.true.) if (present(forces)) & @@ -1611,57 +1360,28 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl ! Set up the restarts. call restart_init(param_file, CS%restart_CSp, "Shelf.res") - vd = var_desc("shelf_mass","kg m-2","Ice shelf mass",z_grid='1') - call register_restart_field(CS%mass_shelf, vd, .true., CS%restart_CSp) - vd = var_desc("shelf_area","m2","Ice shelf area in cell",z_grid='1') - call register_restart_field(CS%area_shelf_h, vd, .true., CS%restart_CSp) - vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') - call register_restart_field(CS%h_shelf, vd, .true., CS%restart_CSp) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - ! additional restarts for ice shelf state - vd = var_desc("u_shelf","m s-1","ice sheet/shelf velocity",'q',z_grid='1') - call register_restart_field(CS%u_shelf, vd, .true., CS%restart_CSp) - vd = var_desc("v_shelf","m s-1","ice sheet/shelf velocity",'q',z_grid='1') - call register_restart_field(CS%v_shelf, vd, .true., CS%restart_CSp) - !vd = var_desc("h_shelf","m","ice sheet/shelf thickness",z_grid='1') - !call register_restart_field(CS%h_shelf, vd, .true., CS%restart_CSp) - - vd = var_desc("h_mask","none","ice sheet/shelf thickness mask",z_grid='1') - call register_restart_field(CS%hmask, vd, .true., CS%restart_CSp) - - ! OVS vertically integrated stream/shelf temperature - vd = var_desc("t_shelf","deg C","ice sheet/shelf temperature",z_grid='1') - call register_restart_field(CS%t_shelf, vd, .true., CS%restart_CSp) - - - ! vd = var_desc("area_shelf_h","m-2","ice-covered area of a cell",z_grid='1') - ! call register_restart_field(CS%area_shelf_h, CS%area_shelf_h, vd, .true., CS%restart_CSp) - - vd = var_desc("OD_av","m","avg ocean depth in a cell",z_grid='1') - call register_restart_field(CS%OD_av, vd, .true., CS%restart_CSp) - - ! vd = var_desc("OD_av_rt","m","avg ocean depth in a cell, intermed",z_grid='1') - ! call register_restart_field(CS%OD_av_rt, CS%OD_av_rt, vd, .true., CS%restart_CSp) - - vd = var_desc("float_frac","m","degree of grounding",z_grid='1') - call register_restart_field(CS%float_frac, vd, .true., CS%restart_CSp) - - ! vd = var_desc("float_frac_rt","m","degree of grounding, intermed",z_grid='1') - ! call register_restart_field(CS%float_frac_rt, CS%float_frac_rt, vd, .true., CS%restart_CSp) - - vd = var_desc("viscosity","m","glens law ice visc",z_grid='1') - call register_restart_field(CS%ice_visc_bilinear, vd, .true., CS%restart_CSp) - vd = var_desc("tau_b_beta","m","coefficient of basal traction",z_grid='1') - call register_restart_field(CS%taub_beta_eff_bilinear, vd, .true., CS%restart_CSp) + call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & + "Ice shelf mass", "kg m-2") + call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & + "Ice shelf area in cell", "m2") + call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & + "ice sheet/shelf thickness", "m") + if (CS%active_shelf_dynamics) then + call register_restart_field(ISS%hmask, "h_mask", .true., CS%restart_CSp, & + "ice sheet/shelf thickness mask" ,"none") endif + ! if (CS%active_shelf_dynamics) then !### Consider adding an ice shelf dynamics switch. + ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics + call register_ice_shelf_dyn_restarts(G, 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 - ! vd = var_desc("ustar_shelf","m s-1","Friction velocity under ice shelves",z_grid='1') - ! call register_restart_field(fluxes%ustar_shelf, vd, .true., CS%restart_CSp) - ! vd = var_desc("iceshelf_melt","m year-1","Ice Shelf Melt Rate",z_grid='1') - ! call register_restart_field(fluxes%iceshelf_melt, vd, .true., CS%restart_CSp) + !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") + ! call register_restart_field(fluxes%iceshelf_melt, "iceshelf_melt", .false., CS%restart_CSp, & + ! "Ice Shelf Melt Rate", "m year-1") !endif CS%restart_output_dir = dirs%restart_output_dir @@ -1673,218 +1393,90 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (CS%override_shelf_movement .and. CS%mass_from_file) then ! initialize the ids for reading shelf mass from a netCDF - call initialize_shelf_mass(G, param_file, CS) + call initialize_shelf_mass(G, param_file, CS, ISS) if (new_sim) then ! new simulation, initialize ice thickness as in the static case - call initialize_ice_thickness (CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, G, param_file) ! next make sure mass is consistent with thickness - do j=G%jsd,G%jed - do i=G%isd,G%ied - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif - enddo - enddo - - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) - endif + enddo ; enddo + if (CS%min_thickness_simple_calve > 0.0) & + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) endif + endif - ! else if (CS%shelf_mass_is_dynamic) then - ! call initialize_ice_shelf_boundary ( CS%u_face_mask_boundary, CS%v_face_mask_boundary, & - ! CS%u_flux_boundary_values, CS%v_flux_boundary_values, & - ! CS%u_boundary_values, CS%v_boundary_values, CS%h_boundary_values, & -! CS%hmask, G, param_file) - end if - - if (CS%shelf_mass_is_dynamic .and. .not. CS%override_shelf_movement) then - ! the only reason to initialize boundary conds is if the shelf is dynamic + if (CS%active_shelf_dynamics) then + ! the only reason to initialize boundary conds is if the shelf is dynamic - MJH - !MJHcall initialize_ice_shelf_boundary ( CS%u_face_mask_boundary, CS%v_face_mask_boundary, & - !MJH CS%u_flux_boundary_values, CS%v_flux_boundary_values, & - !MJH CS%u_boundary_values, CS%v_boundary_values, CS%h_boundary_values, & - !MJH CS%hmask, G, param_file) + ! call initialize_ice_shelf_boundary ( CS%u_face_mask_bdry, CS%v_face_mask_bdry, & + ! CS%u_flux_bdry_val, CS%v_flux_bdry_val, & + ! CS%u_bdry_val, CS%v_bdry_val, CS%h_bdry_val, & + ! ISS%hmask, G, param_file) - end if + endif if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then ! This model is initialized internally or from a file. - call initialize_ice_thickness (CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) + call initialize_ice_thickness(ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, G, param_file) ! next make sure mass is consistent with thickness - do j=G%jsd,G%jed - do i=G%isd,G%ied - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice - endif - enddo - enddo + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice + endif + enddo ; enddo ! else ! Previous block for new_sim=.T., this block restores the state. elseif (.not.new_sim) then - ! This line calls a subroutine that reads the initial conditions - ! from a restart file. - call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, & + ! This line calls a subroutine that reads the initial conditions from a restart file. + 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) - - ! i think this call isnt necessary - all it does is set hmask to 3 at - ! the dirichlet boundary, and now this is done elsewhere - ! call initialize_shelf_mass(G, param_file, CS, .false.) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - - ! this is unfortunately necessary; if grid is not symmetric the boundary values - ! of u and v are otherwise not set till the end of the first linear solve, and so - ! viscosity is not calculated correctly - if (.not. G%symmetric) then - do j=G%jsd,G%jed - do i=G%isd,G%ied - if (((i+G%idg_offset) .eq. (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j).eq.3)) then - CS%u_shelf (i-1,j-1) = CS%u_boundary_values (i-1,j-1) - CS%u_shelf (i-1,j) = CS%u_boundary_values (i-1,j) - endif - if (((j+G%jdg_offset) .eq. (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1).eq.3)) then - CS%u_shelf (i-1,j-1) = CS%u_boundary_values (i-1,j-1) - CS%u_shelf (i,j-1) = CS%u_boundary_values (i,j-1) - endif - enddo - enddo - endif - - call pass_var (CS%OD_av,G%domain) - call pass_var (CS%float_frac,G%domain) - call pass_var (CS%ice_visc_bilinear,G%domain) - call pass_var (CS%taub_beta_eff_bilinear,G%domain) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var (CS%area_shelf_h,G%domain) - call pass_var (CS%h_shelf,G%domain) - call pass_var (CS%hmask,G%domain) - - if (is_root_pe()) PRINT *, "RESTORING ICE SHELF FROM FILE!!!!!!!!!!!!!" - endif - endif ! .not. new_sim CS%Time = Time - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%mass_shelf, G%domain) - - ! Transfer the appropriate fields to the forcing type. - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - call cpu_clock_begin(id_clock_pass) - call pass_var(G%bathyT, G%domain) - call pass_var(CS%hmask, G%domain) - call update_velocity_masks (CS) - call cpu_clock_end(id_clock_pass) - endif + call cpu_clock_begin(id_clock_pass) + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%mass_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) + call pass_var(G%bathyT, G%domain) + call cpu_clock_end(id_clock_pass) do j=jsd,jed ; do i=isd,ied - if (CS%area_shelf_h(i,j) > G%areaT(i,j)) then + if (ISS%area_shelf_h(i,j) > G%areaT(i,j)) then call MOM_error(WARNING,"Initialize_ice_shelf: area_shelf_h exceeds G%areaT.") - CS%area_shelf_h(i,j) = G%areaT(i,j) - endif - if (present(fluxes)) then - if (G%areaT(i,j) > 0.0) fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) - if (associated(fluxes%p_surf)) & - fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + & - fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) - if (associated(fluxes%p_surf_full)) & - fluxes%p_surf_full(i,j) = fluxes%p_surf_full(i,j) + & - fluxes%frac_shelf_h(i,j) * (CS%g_Earth * CS%mass_shelf(i,j)) + ISS%area_shelf_h(i,j) = G%areaT(i,j) endif enddo ; enddo + if (present(fluxes)) then ; do j=jsd,jed ; do i=isd,ied + if (G%areaT(i,j) > 0.0) fluxes%frac_shelf_h(i,j) = ISS%area_shelf_h(i,j) / G%areaT(i,j) + enddo ; enddo ; endif if (CS%DEBUG) then - call hchksum (fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) - endif - - if (present(forces) .and. .not. CS%solo_ice_sheet) then - do j=jsd,jed ; do i=isd,ied-1 - forces%frac_shelf_u(I,j) = 0.0 - if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & - forces%frac_shelf_u(I,j) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i+1,j)) / & - (G%areaT(i,j) + G%areaT(i+1,j))) - forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & - min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) - enddo ; enddo - - - do j=jsd,jed-1 ; do i=isd,ied - forces%frac_shelf_v(i,J) = 0.0 - if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & - forces%frac_shelf_v(i,J) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i,j+1)) / & - (G%areaT(i,j) + G%areaT(i,j+1))) - forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & - min(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) - enddo ; enddo - endif - - if (present(forces) .and. .not.CS%solo_ice_sheet) then - call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) + call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) endif - ! call savearray2 ('frac_shelf_u'//procnum,forces%frac_shelf_u,CS%write_output_to_file) - ! call savearray2 ('frac_shelf_v'//procnum,forces%frac_shelf_v,CS%write_output_to_file) - ! call savearray2 ('frac_shelf_h'//procnum,fluxes%frac_shelf_h,CS%write_output_to_file) - ! call savearray2 ('area_shelf_h'//procnum,CS%area_shelf_h,CS%write_output_to_file) - ! if we are calving to a mask, i.e. if a mask exists where a shelf cannot, then we read - ! the mask from a file + if (present(forces)) & + call add_shelf_forces(G, CS, forces, do_shelf_area=.not.CS%solo_ice_sheet) - if (CS%shelf_mass_is_dynamic .and. CS%calve_to_mask .and. & - .not.CS%override_shelf_movement) then + if (present(fluxes)) call add_shelf_pressure(G, CS, fluxes) - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") - - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) - call get_param(param_file, mdl, "CALVING_MASK_FILE", IC_file, & - "The file with a mask for where calving might occur.", & - default="ice_shelf_h.nc") - call get_param(param_file, mdl, "CALVING_MASK_VARNAME", var_name, & - "The variable to use in masking calving.", & - default="area_shelf_h") - - filename = trim(inputdir)//trim(IC_file) - call log_param(param_file, mdl, "INPUTDIR/CALVING_MASK_FILE", filename) - if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & - " calving mask file: Unable to open "//trim(filename)) - - call MOM_read_data(filename,trim(var_name),CS%calve_mask,G%Domain) - do j=G%jsc,G%jec - do i=G%isc,G%iec - if (CS%calve_mask(i,j) > 0.0) CS%calve_mask(i,j) = 1.0 - enddo - enddo - - call pass_var (CS%calve_mask,G%domain) + if (CS%active_shelf_dynamics .and. .not.CS%isthermo) then + ISS%water_flux(:,:) = 0.0 endif - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then -! call init_boundary_values (CS, time, CS%input_flux, CS%input_thickness, new_sim) - - if (.not. CS%isthermo) then - CS%lprec(:,:) = 0.0 - endif - - - if (new_sim) then - if (is_root_pe()) print *,"NEW SIM: initialize velocity" - call update_OD_ffrac_uncoupled (CS) - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, 1, iters, Time) - -! write (procnum,'(I2)') mpp_pe() - - 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) - endif - endif + if (shelf_mass_is_dynamic) & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, diag, new_sim, solo_ice_sheet_in) call get_param(param_file, mdl, "SAVE_INITIAL_CONDS", save_IC, & "If true, save the ice shelf initial conditions.", & @@ -1895,7 +1487,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (save_IC .and. .not.((dirs%input_filename(1:1) == 'r') .and. & (LEN_TRIM(dirs%input_filename) == 1))) then - call save_restart(dirs%output_directory, CS%Time, G, & CS%restart_CSp, filename=IC_file) endif @@ -1905,6 +1496,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 'Ice Shelf Area in cell', 'meter-2') CS%id_shelf_mass = register_diag_field('ocean_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & 'mass of shelf', 'kg/m^2') + CS%id_h_shelf = register_diag_field('ocean_model', 'h_shelf', CS%diag%axesT1, CS%Time, & + 'ice shelf thickness', 'm') CS%id_mass_flux = register_diag_field('ocean_model', 'mass_flux', CS%diag%axesT1,& CS%Time,'Total mass flux of freshwater across the ice-ocean interface.', 'kg/s') CS%id_melt = register_diag_field('ocean_model', 'melt', CS%diag%axesT1, CS%Time, & @@ -1929,40 +1522,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl 'Heat conduction into ice shelf', 'W m-2') CS%id_ustar_shelf = register_diag_field('ocean_model', 'ustar_shelf', CS%diag%axesT1, CS%Time, & 'Fric vel under shelf', 'm/s') - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1,CS%Time, & - 'x-velocity of ice', 'm yr-1') - CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1,CS%Time, & - 'y-velocity of ice', 'm yr-1') - CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1,CS%Time, & - 'mask for u-nodes', 'none') - CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1,CS%Time, & - 'mask for v-nodes', 'none') - CS%id_h_mask = register_diag_field('ocean_model','h_mask',CS%diag%axesT1,CS%Time, & - 'ice shelf thickness', 'none') - CS%id_surf_elev = register_diag_field('ocean_model','ice_surf',CS%diag%axesT1,CS%Time, & - 'ice surf elev', 'm') - CS%id_float_frac = register_diag_field('ocean_model','ice_float_frac',CS%diag%axesT1,CS%Time, & - 'fraction of cell that is floating (sort of)', 'none') - CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1,CS%Time, & - 'ocean column thickness passed to ice model', 'm') - CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1,CS%Time, & - 'intermediate ocean column thickness passed to ice model', 'm') - CS%id_float_frac_rt = register_diag_field('ocean_model','float_frac_rt',CS%diag%axesT1,CS%Time, & - 'timesteps where cell is floating ', 'none') - !CS%id_h_after_uflux = register_diag_field('ocean_model','h_after_uflux',CS%diag%axesh1,CS%Time, & - ! 'thickness after u flux ', 'none') - !CS%id_h_after_vflux = register_diag_field('ocean_model','h_after_vflux',CS%diag%axesh1,CS%Time, & - ! 'thickness after v flux ', 'none') - !CS%id_h_after_adv = register_diag_field('ocean_model','h_after_adv',CS%diag%axesh1,CS%Time, & - ! 'thickness after front adv ', 'none') - -!!! OVS vertically integrated temperature - CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1,CS%Time, & - 'T of ice', 'oC') - CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1,CS%Time, & - 'mask for T-nodes', 'none') + if (CS%active_shelf_dynamics) then + CS%id_h_mask = register_diag_field('ocean_model', 'h_mask', CS%diag%axesT1, CS%Time, & + 'ice shelf thickness mask', 'none') endif id_clock_shelf = cpu_clock_id('Ice shelf', grain=CLOCK_COMPONENT) @@ -1971,12 +1533,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl end subroutine initialize_ice_shelf !> Initializes shelf mass based on three options (file, zero and user) -subroutine initialize_shelf_mass(G, param_file, CS, new_sim) +subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) - type(ocean_grid_type), intent(in) :: G + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ice_shelf_CS), pointer :: CS - logical, optional :: new_sim + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated + logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted integer :: i, j, is, ie, js, je logical :: read_shelf_area, new_sim_2 @@ -1986,11 +1549,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) character(len=40) :: mdl = "MOM_ice_shelf" is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (.not. present(new_sim)) then - new_sim_2 = .true. - else - new_sim_2 = .false. - endif + new_sim_2 = .true. ; if (present(new_sim)) new_sim_2 = new_sim call get_param(param_file, mdl, "ICE_SHELF_CONFIG", config, & "A string that specifies how the ice shelf is \n"//& @@ -2023,14 +1582,8 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) filename = trim(slasher(inputdir))//trim(shelf_file) call log_param(param_file, mdl, "INPUTDIR/SHELF_FILE", filename) - if (CS%DEBUG) then - CS%id_read_mass = init_external_field(filename,shelf_mass_var, & - domain=G%Domain%mpp_domain,verbose=.true.) - else - CS%id_read_mass = init_external_field(filename,shelf_mass_var, & - domain=G%Domain%mpp_domain) - - endif + CS%id_read_mass = init_external_field(filename, shelf_mass_var, & + domain=G%Domain%mpp_domain, verbose=CS%debug) if (read_shelf_area) then call get_param(param_file, mdl, "SHELF_AREA_VAR", shelf_area_var, & @@ -2038,7 +1591,7 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) default="shelf_area") CS%id_read_area = init_external_field(filename,shelf_area_var, & - domain=G%Domain%mpp_domain) + domain=G%Domain%mpp_domain) endif if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & @@ -2046,13 +1599,13 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) case ("zero") do j=js,je ; do i=is,ie - CS%mass_shelf(i,j) = 0.0 - CS%area_shelf_h(i,j) = 0.0 + ISS%mass_shelf(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 enddo ; enddo case ("USER") - call USER_initialize_shelf_mass(CS%mass_shelf, CS%area_shelf_h, & - CS%h_shelf, CS%hmask, G, CS%user_CS, param_file, new_sim_2) + call USER_initialize_shelf_mass(ISS%mass_shelf, ISS%area_shelf_h, & + ISS%h_shelf, ISS%hmask, G, CS%user_CS, param_file, new_sim_2) case default ; call MOM_error(FATAL,"initialize_ice_shelf: "// & "Unrecognized ice shelf setup "//trim(config)) @@ -2061,106 +1614,43 @@ subroutine initialize_shelf_mass(G, param_file, CS, new_sim) end subroutine initialize_shelf_mass !> Updates the ice shelf mass using data from a file. -subroutine update_shelf_mass(G, CS, Time, fluxes) - type(ocean_grid_type), intent(inout) :: G - type(ice_shelf_CS), pointer :: CS - type(time_type), intent(in) :: Time - type(forcing), intent(inout) :: fluxes +subroutine update_shelf_mass(G, CS, ISS, Time) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< The ice shelf state type that is being updated + type(time_type), intent(in) :: Time !< The current model time ! local variables integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - ! first, zero out fluxes applied during previous time step - do j=js,je; do i=is,ie - - - enddo; enddo - - call time_interp_external(CS%id_read_mass, Time, CS%mass_shelf) + call time_interp_external(CS%id_read_mass, Time, ISS%mass_shelf) do j=js,je ; do i=is,ie - ! first, zero out fluxes applied during previous time step - if (CS%area_shelf_h(i,j) > 0.0) then - if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 - if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 - if (associated(fluxes%frac_shelf_h)) fluxes%frac_shelf_h(i,j) = 0.0 - if (associated(fluxes%p_surf)) fluxes%p_surf(i,j) = 0.0 - if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 - endif - CS%area_shelf_h(i,j) = 0.0 - CS%hmask(i,j) = 0. - if (CS%mass_shelf(i,j) > 0.0) then - CS%area_shelf_h(i,j) = G%areaT(i,j) - CS%h_shelf(i,j) = CS%mass_shelf(i,j)/CS%density_ice - CS%hmask(i,j) = 1. - endif + ISS%area_shelf_h(i,j) = 0.0 + ISS%hmask(i,j) = 0. + if (ISS%mass_shelf(i,j) > 0.0) then + ISS%area_shelf_h(i,j) = G%areaT(i,j) + ISS%h_shelf(i,j) = ISS%mass_shelf(i,j)/CS%density_ice + ISS%hmask(i,j) = 1. + endif enddo ; enddo - !call USER_update_shelf_mass(CS%mass_shelf, CS%area_shelf_h, CS%h_shelf, & - ! CS%hmask, CS%grid, CS%user_CS, Time, .true.) + !call USER_update_shelf_mass(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, & + ! ISS%hmask, CS%grid, CS%user_CS, Time, .true.) if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) endif - call pass_var(CS%area_shelf_h, G%domain) - call pass_var(CS%h_shelf, G%domain) - call pass_var(CS%hmask, G%domain) - call pass_var(CS%mass_shelf, G%domain) - - - ! update psurf and frac_shelf_h in fluxes - do j=js,je ; do i=is,ie - if (associated(fluxes%p_surf)) & - fluxes%p_surf(i,j) = (CS%g_Earth * CS%mass_shelf(i,j)) - if (associated(fluxes%p_surf_full)) & - fluxes%p_surf_full(i,j) = (CS%g_Earth * CS%mass_shelf(i,j)) - if (G%areaT(i,j) > 0.0) & - fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) - enddo ; enddo - + call pass_var(ISS%area_shelf_h, G%domain) + call pass_var(ISS%h_shelf, G%domain) + call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%mass_shelf, G%domain) end subroutine update_shelf_mass -subroutine initialize_diagnostic_fields (CS, FE, Time) - type(ice_shelf_CS), pointer :: CS - integer :: FE - type(time_type), intent(in) :: Time - - type(ocean_grid_type), pointer :: G - integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi, rhow, OD - type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac, h_shelf - - G => CS%grid - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - dummy_time = set_time (0,0) - OD_av => CS%OD_av - h_shelf => CS%h_shelf - float_frac => CS%float_frac - isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - - do j=jsd,jed - do i=isd,ied - OD = G%bathyT(i,j) - rhoi/rhow * h_shelf (i,j) - if (OD.ge.0) then - ! ice thickness does not take up whole ocean column -> floating - OD_av (i,j) = OD - float_frac(i,j) = 0. - else - OD_av (i,j) = 0. - float_frac(i,j) = 1. - endif - enddo - enddo - - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, FE, iters, dummy_time) - -end subroutine initialize_diagnostic_fields - !> Save the ice shelf restart file subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_suffix) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure @@ -2172,23 +1662,11 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su character(len=*), optional, intent(in) :: filename_suffix !< An optional suffix (e.g., a !! time-stamp) to append to the restart file names. ! local variables - type(ocean_grid_type), pointer :: G + type(ocean_grid_type), pointer :: G => NULL() character(len=200) :: restart_dir - character(2) :: procnum G => CS%grid -! write (procnum,'(I2)') mpp_pe() - - !### THESE ARE ONLY HERE FOR DEBUGGING? -! call savearray2 ("U_before_"//"p"//trim(procnum),CS%u_shelf,CS%write_output_to_file) -! call savearray2 ("V_before_"//"p"//trim(procnum),CS%v_shelf,CS%write_output_to_file) -! call savearray2 ("H_before_"//"p"//trim(procnum),CS%h_shelf,CS%write_output_to_file) -! call savearray2 ("Hmask_before_"//"p"//trim(procnum),CS%hmask,CS%write_output_to_file) -! call savearray2 ("Harea_before_"//"p"//trim(procnum),CS%area_shelf_h,CS%write_output_to_file) -! call savearray2 ("Visc_before_"//"p"//trim(procnum),CS%ice_visc_bilinear,CS%write_output_to_file) -! call savearray2 ("taub_before_"//"p"//trim(procnum),CS%taub_beta_eff_bilinear,CS%write_output_to_file) -! call savearray2 ("taub_before_"//"p"//trim(procnum),CS%taub_beta_eff_bilinear,CS%write_output_to_file) if (present(directory)) then ; restart_dir = directory else ; restart_dir = CS%restart_output_dir ; endif @@ -2196,4490 +1674,99 @@ subroutine ice_shelf_save_restart(CS, Time, directory, time_stamped, filename_su end subroutine ice_shelf_save_restart +!> Deallocates all memory associated with this module +subroutine ice_shelf_end(CS) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure -subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real,pointer,dimension(:,:),intent(in) :: melt_rate - type(time_type) :: Time - -! time_step: time step in sec -! melt_rate: basal melt rate in kg/m^2/s - -! 3/8/11 DNG -! Arguments: -! CS - A structure containing the ice shelf state - including current velocities -! h0 - an array containing the thickness at the beginning of the call -! h_after_uflux - an array containing the thickness after advection in u-direction -! h_after_vflux - similar -! -! This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. -! ADDITIONALLY, it will update the volume of ice in partially-filled cells, and update -! hmask accordingly -! -! The flux overflows are included here. That is because they will be used to advect 3D scalars -! into partial cells - - ! - ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given - ! cell across its boundaries. - ! ###Perhaps flux_enter should be changed into u-face and v-face - ! ###fluxes, which can then be used in halo updates, etc. - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - type(ocean_grid_type), pointer :: G - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2)) :: h_after_uflux, h_after_vflux - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2),4) :: flux_enter - integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy, thick_bd - real, dimension(:,:), pointer :: hmask - character(len=2) :: procnum - - hmask => CS%hmask - G => CS%grid - rho = CS%density_ice - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter (:,:,:) = 0.0 - - h_after_uflux (:,:) = 0.0 - h_after_vflux (:,:) = 0.0 -! if (is_root_pe()) write(*,*) "ice_shelf_advect called" - - do j=jsd,jed - do i=isd,ied - thick_bd = CS%thickness_boundary_values(i,j) - if (thick_bd .ne. 0.0) then - CS%h_shelf(i,j) = CS%thickness_boundary_values(i,j) - endif - enddo - enddo + if (.not.associated(CS)) return - call ice_shelf_advect_thickness_x (CS, time_step/spy, CS%h_shelf, h_after_uflux, flux_enter) + call ice_shelf_state_end(CS%ISS) -! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var (h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! call disable_averaging(CS%diag) + if (CS%active_shelf_dynamics) call ice_shelf_dyn_end(CS%dCS) - call ice_shelf_advect_thickness_y (CS, time_step/spy, h_after_uflux, h_after_vflux, flux_enter) - -! call enable_averaging(time_step,Time,CS%diag) -! call pass_var (h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) - - do j=jsd,jed - do i=isd,ied - if (CS%hmask(i,j) .eq. 1) then - CS%h_shelf (i,j) = h_after_vflux(i,j) - endif - enddo - enddo - - if (CS%moving_shelf_front) then - call shelf_advance_front (CS, flux_enter) - if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) - endif - if (CS%calve_to_mask) then - call calve_to_mask (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask, CS%calve_mask) - endif - endif - - !call enable_averaging(time_step,Time,CS%diag) - !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, CS%h_shelf, CS%diag) - !call disable_averaging(CS%diag) - - !call change_thickness_using_melt(CS,G,time_step, fluxes) - - call update_velocity_masks (CS) - -end subroutine ice_shelf_advect - -subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) - type(ice_shelf_CS), pointer :: CS - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - integer, intent(in) :: FE - integer, intent(out) :: iters - type(time_type), intent(in) :: time - - real, dimension(:,:), pointer :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, & - u_bdry_cont, v_bdry_cont, Au, Av, err_u, err_v, & - geolonq, geolatq, u_last, v_last, float_cond, H_node - type(ocean_grid_type), pointer :: G - integer :: conv_flag, i, j, k,l, iter, isym, & - isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi, rhow - real, pointer, dimension(:,:,:,:) :: Phi - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension (8,4) :: Phi_temp - real, dimension (2,2) :: X,Y - character(2) :: iternum - character(2) :: procnum, numproc - - ! for GL interpolation - need to make this a readable parameter - nsub = CS%n_sub_regularize - - G => CS%grid - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - ALLOCATE (TAUDX (isdq:iedq,jsdq:jedq) ) ; TAUDX(:,:)=0 - ALLOCATE (TAUDY (isdq:iedq,jsdq:jedq) ) ; TAUDY(:,:)=0 - ALLOCATE (u_prev_iterate (isdq:iedq,jsdq:jedq) ) - ALLOCATE (v_prev_iterate (isdq:iedq,jsdq:jedq) ) - ALLOCATE (u_bdry_cont (isdq:iedq,jsdq:jedq) ) ; u_bdry_cont(:,:)=0 - ALLOCATE (v_bdry_cont (isdq:iedq,jsdq:jedq) ) ; v_bdry_cont(:,:)=0 - ALLOCATE (Au (isdq:iedq,jsdq:jedq) ) ; Au(:,:)=0 - ALLOCATE (Av (isdq:iedq,jsdq:jedq) ) ; Av(:,:)=0 - ALLOCATE (err_u (isdq:iedq,jsdq:jedq) ) - ALLOCATE (err_v (isdq:iedq,jsdq:jedq) ) - ALLOCATE (u_last (isdq:iedq,jsdq:jedq) ) - ALLOCATE (v_last (isdq:iedq,jsdq:jedq) ) - - ! need to make these conditional on GL interpolation - ALLOCATE (float_cond (G%isd:G%ied,G%jsd:G%jed)) ; float_cond(:,:)=0 - ALLOCATE (H_node (G%isdB:G%iedB,G%jsdB:G%jedB)) ; H_node(:,:)=0 - ALLOCATE (Phisub (nsub,nsub,2,2,2,2)) ; Phisub = 0.0 - - geolonq => G%geoLonBu ; geolatq => G%geoLatBu - - if (G%isc+G%idg_offset==G%isg) then - ! tile is at west bdry - isumstart = G%iscB - else - ! tile is interior - isumstart = ISUMSTART_INT_ - endif - - if (G%jsc+G%jdg_offset==G%jsg) then - ! tile is at south bdry - jsumstart = G%jscB - else - ! tile is interior - jsumstart = JSUMSTART_INT_ - endif - - call calc_shelf_driving_stress (CS, TAUDX, TAUDY, CS%OD_av, FE) - - ! 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 - ! floatation condition is estimated by assuming topography is cellwise constant - ! and H is bilinear in a cell; floating where rho_i/rho_w * H_node + D is nonpositive - - ! need to make this conditional on GL interp - - if (CS%GL_regularize) then - - call interpolate_H_to_B (CS, CS%h_shelf, CS%hmask, H_node) - call savearray2 ("H_node",H_node,CS%write_output_to_file) - - do j=G%jsc,G%jec - do i=G%isc,G%iec - nodefloat = 0 - do k=0,1 - do l=0,1 - if ((CS%hmask(i,j) .eq. 1) .and. & - (rhoi/rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) .le. 0)) then - nodefloat = nodefloat + 1 - endif - enddo - enddo - if ((nodefloat .gt. 0) .and. (nodefloat .lt. 4)) then - !print *,"nodefloat",nodefloat - float_cond (i,j) = 1.0 - CS%float_frac (i,j) = 1.0 - endif - enddo - enddo - call savearray2 ("float_cond",float_cond,CS%write_output_to_file) - - call pass_var (float_cond, G%Domain) - - call bilinear_shape_functions_subgrid (Phisub, nsub) - - call savearray2("Phisub1111",Phisub(:,:,1,1,1,1),CS%write_output_to_file) - - endif - - ! make above conditional - - u_prev_iterate (:,:) = u(:,:) - v_prev_iterate (:,:) = v(:,:) - - isym=0 - - ! must prepare phi - if (FE .eq. 1) then - allocate (Phi (isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:)=0 - - do j=jsd,jed - do i=isd,ied - - if (((i .gt. isd) .and. (j .gt. jsd)) .or. (isym .eq. 1)) then - X(:,:) = geolonq (i-1:i,j-1:j)*1000 - Y(:,:) = geolatq (i-1:i,j-1:j)*1000 - else - X(2,:) = geolonq(i,j)*1000 - X(1,:) = geolonq(i,j)*1000-G%dxT(i,j) - Y(:,2) = geolatq(i,j)*1000 - Y(:,1) = geolatq(i,j)*1000-G%dyT(i,j) - endif - - call bilinear_shape_functions (X, Y, Phi_temp, area) - Phi (i,j,:,:) = Phi_temp - - enddo - enddo - endif - - if (FE .eq. 1) then - call calc_shelf_visc_bilinear (CS, u, v) - - call pass_var (CS%ice_visc_bilinear, G%domain) - call pass_var (CS%taub_beta_eff_bilinear, G%domain) - else - call calc_shelf_visc_triangular (CS,u,v) - - call pass_var (CS%ice_visc_upper_tri, G%domain) - call pass_var (CS%taub_beta_eff_upper_tri, G%domain) - call pass_var (CS%ice_visc_lower_tri, G%domain) - call pass_var (CS%taub_beta_eff_lower_tri, G%domain) - endif - - ! 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 - if (FE .eq. 1) then - CS%taub_beta_eff_bilinear (i,j) = CS%taub_beta_eff_bilinear (i,j) * CS%float_frac (i,j) - else - CS%taub_beta_eff_upper_tri (i,j) = CS%taub_beta_eff_upper_tri (i,j) * CS%float_frac (i,j) - CS%taub_beta_eff_lower_tri (i,j) = CS%taub_beta_eff_lower_tri (i,j) * CS%float_frac (i,j) - endif - enddo - enddo - - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & - rhoi/rhow, u_bdry_cont, v_bdry_cont) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, u_bdry_cont, v_bdry_cont) - endif - - Au(:,:) = 0.0 ; Av(:,:) = 0.0 - - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & - CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, & - G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & - CS%ice_visc_lower_tri, CS%taub_beta_eff_upper_tri, CS%taub_beta_eff_lower_tri, & - G%dxT, G%dyT, G%areaT, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, isym) - endif - -! write (procnum,'(I2)') mpp_pe() - - - err_init = 0 ; err_tempu = 0; err_tempv = 0 - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then - err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) - endif - if (CS%vmask(i,j) .eq. 1) then - err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) - endif - if (err_tempv .ge. err_init) then - err_init = err_tempv - endif - enddo - enddo - - call mpp_max (err_init) - - if (is_root_pe()) print *,"INITIAL nonlinear residual: ",err_init - - u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:) - - !! begin loop - - do iter=1,100 - - - call ice_shelf_solve_inner (CS, u, v, TAUDX, TAUDY, H_node, float_cond, & - FE, conv_flag, iters, time, Phi, Phisub) - - - if (CS%DEBUG) then - call qchksum (u, "u shelf", G%HI, haloshift=2) - call qchksum (v, "v shelf", G%HI, haloshift=2) - endif - - if (is_root_pe()) print *,"linear solve done",iters," iterations" - - if (FE .eq. 1) then - call calc_shelf_visc_bilinear (CS,u,v) - call pass_var (CS%ice_visc_bilinear, G%domain) - call pass_var (CS%taub_beta_eff_bilinear, G%domain) - else - call calc_shelf_visc_triangular (CS,u,v) - call pass_var (CS%ice_visc_upper_tri, G%domain) - call pass_var (CS%taub_beta_eff_upper_tri, G%domain) - call pass_var (CS%ice_visc_lower_tri, G%domain) - call pass_var (CS%taub_beta_eff_lower_tri, G%domain) - endif - - if (iter .eq. 1) then -! call savearray2 ("visc1",CS%ice_visc_bilinear,CS%write_output_to_file) - endif - - ! 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 - if (FE .eq. 1) then - CS%taub_beta_eff_bilinear (i,j) = CS%taub_beta_eff_bilinear (i,j) * CS%float_frac (i,j) - else - CS%taub_beta_eff_upper_tri (i,j) = CS%taub_beta_eff_upper_tri (i,j) * CS%float_frac (i,j) - CS%taub_beta_eff_lower_tri (i,j) = CS%taub_beta_eff_lower_tri (i,j) * CS%float_frac (i,j) - endif - enddo - enddo - - u_bdry_cont (:,:) = 0 ; v_bdry_cont (:,:) = 0 - - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & - rhoi/rhow, u_bdry_cont, v_bdry_cont) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, u_bdry_cont, v_bdry_cont) - endif - - Au(:,:) = 0 ; Av(:,:) = 0 - - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & - CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, G%isc-1, & - G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & - CS%ice_visc_lower_tri, CS%taub_beta_eff_upper_tri, CS%taub_beta_eff_lower_tri, & - G%dxT, G%dyT, G%areaT, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, isym) - endif - - err_max = 0 - - if (CS%nonlin_solve_err_mode .eq. 1) then - - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then - err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) - endif - if (CS%vmask(i,j) .eq. 1) then - err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) - endif - if (err_tempv .ge. err_max) then - err_max = err_tempv - endif - enddo - enddo - - call mpp_max (err_max) - - elseif (CS%nonlin_solve_err_mode .eq. 2) then - - max_vel = 0 ; tempu = 0 ; tempv = 0 - - do j=jsumstart,G%jecB - do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then - err_tempu = ABS (u_last(i,j)-u(i,j)) - tempu = u(i,j) - endif - if (CS%vmask(i,j) .eq. 1) then - err_tempv = MAX(ABS (v_last(i,j)- v(i,j)), err_tempu) - tempv = SQRT(v(i,j)**2+tempu**2) - endif - if (err_tempv .ge. err_max) then - err_max = err_tempv - endif - if (tempv .ge. max_vel) then - max_vel = tempv - endif - enddo - enddo - - u_last (:,:) = u(:,:) - v_last (:,:) = v(:,:) - - call mpp_max (max_vel) - call mpp_max (err_max) - err_init = max_vel - - endif - - if (is_root_pe()) print *,"nonlinear residual: ",err_max/err_init - - if (err_max .le. CS%nonlinear_tolerance * err_init) then - if (is_root_pe()) & - print *,"exiting nonlinear solve after ",iter," iterations" - exit - endif - - enddo - - !write (procnum,'(I1)') mpp_pe() - !write (numproc,'(I1)') mpp_npes() - - DEALLOCATE (TAUDX) - DEALLOCATE (TAUDY) - DEALLOCATE (u_prev_iterate) - DEALLOCATE (v_prev_iterate) - DEALLOCATE (u_bdry_cont) - DEALLOCATE (v_bdry_cont) - DEALLOCATE (Au) - DEALLOCATE (Av) - DEALLOCATE (err_u) - DEALLOCATE (err_v) - DEALLOCATE (u_last) - DEALLOCATE (v_last) - DEALLOCATE (H_node) - DEALLOCATE (float_cond) - DEALLOCATE (Phisub) - -end subroutine ice_shelf_solve_outer - -subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE, conv_flag, iters, time, Phi, Phisub) - type(ice_shelf_CS), pointer :: CS - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: taudx, taudy, H_node - real, dimension(:,:),intent(in) :: float_cond - integer, intent(in) :: FE - integer, intent(out) :: conv_flag, iters - type(time_type) :: time - real, pointer, dimension(:,:,:,:) :: Phi - real, dimension (:,:,:,:,:,:),pointer :: Phisub - -! one linear solve (nonlinear iteration) of the solution for velocity - -! in this subroutine: -! boundary contributions are added to taud to get the RHS -! diagonal of matrix is found (for Jacobi precondition) -! CG iteration is carried out for max. iterations or until convergence - -! assumed - u, v, taud, visc, beta_eff are valid on the halo - - - real, dimension(:,:), pointer :: hmask, umask, vmask, u_bdry, v_bdry, & - visc, visc_lo, beta, beta_lo, geolonq, geolatq - real, dimension(LBOUND(u,1):UBOUND(u,1),LBOUND(u,2):UBOUND(u,2)) :: & - Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, & - ubd, vbd, Au, Av, Du, Dv, & - Zu_old, Zv_old, Ru_old, Rv_old, & - sum_vec, sum_vec_2 - integer :: iter, i, j, isym, isd, ied, jsd, jed, & - isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, & - isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo - real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a - type(ocean_grid_type), pointer :: G - character(1) :: procnum - character(2) :: gridsize - - real, dimension (8,4) :: Phi_temp - real, dimension (2,2) :: X,Y - - hmask => CS%hmask - umask => CS%umask - vmask => CS%vmask - u_bdry => CS%u_boundary_values - v_bdry => CS%v_boundary_values - - G => CS%grid - geolonq => G%geoLonBu - geolatq => G%geoLatBu - hmask => CS%hmask - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - - Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 - Ru(:,:) = 0 ; Rv (:,:) = 0 ; Au (:,:) = 0 ; Av (:,:) = 0 - Du(:,:) = 0 ; Dv (:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 - dot_p1 = 0 ; dot_p2 = 0 - -! if (G%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - if (G%isc+G%idg_offset==G%isg) then - ! tile is at west bdry - isumstart = G%iscB - else - ! tile is interior - isumstart = ISUMSTART_INT_ - endif - - if (G%jsc+G%jdg_offset==G%jsg) then - ! tile is at south bdry - jsumstart = G%jscB - else - ! tile is interior - jsumstart = JSUMSTART_INT_ - endif - - if (FE .eq. 1) then - visc => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - elseif (FE .eq. 2) then - visc => CS%ice_visc_upper_tri - visc_lo => CS%ice_visc_lower_tri - beta => CS%taub_beta_eff_upper_tri - beta_lo => CS%taub_beta_eff_lower_tri - endif - - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & - CS%density_ice/CS%density_ocean_avg, ubd, vbd) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, ubd, vbd) - endif - - RHSu(:,:) = taudx(:,:) - ubd(:,:) - RHSv(:,:) = taudy(:,:) - vbd(:,:) - - - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - - - if (FE .eq. 1) then - call matrix_diagonal_bilinear(CS, float_cond, H_node, & - CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) -! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 - elseif (FE .eq. 2) then - call matrix_diagonal_triangle (CS, DIAGu, DIAGv) - DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 - endif - - call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) - - - - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, umask, vmask, hmask, & - H_node, visc, float_cond, G%bathyT, beta, G%areaT, isc-1, iec+1, jsc-1, & - jec+1, CS%density_ice/CS%density_ocean_avg) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, umask, vmask, hmask, visc, visc_lo, & - beta, beta_lo, G%dxT, G%dyT, G%areaT, isc-1, iec+1, jsc-1, jec+1, isym) - endif - - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - - Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) - - if (.not. CS%use_reproducing_sums) then - - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) .eq. 1) dot_p1 = dot_p1 + Ru(i,j)**2 - if (vmask(i,j) .eq. 1) dot_p1 = dot_p1 + Rv(i,j)**2 - enddo - enddo - - call mpp_sum (dot_p1) - - else - - sum_vec(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Ru(i,j)**2 - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 - enddo - enddo - - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - endif - - resid0 = sqrt (dot_p1) - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) .eq. 1) Zu(i,j) = Ru (i,j) / DIAGu (i,j) - if (vmask(i,j) .eq. 1) Zv(i,j) = Rv (i,j) / DIAGv (i,j) - enddo - enddo - - Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) - - cg_halo = 3 - conv_flag = 0 - - !!!!!!!!!!!!!!!!!! - !! !! - !! MAIN CG LOOP !! - !! !! - !!!!!!!!!!!!!!!!!! - - - - ! initially, c-grid data is valid up to 3 halo nodes out - - do iter = 1,CS%cg_max_iterations - - ! assume asymmetry - ! thus we can never assume that any arrays are legit more than 3 vertices past - ! the computational domain - this is their state in the initial iteration - - - is = isc - cg_halo ; ie = iecq + cg_halo - js = jscq - cg_halo ; je = jecq + cg_halo - - Au(:,:) = 0 ; Av(:,:) = 0 - - if (FE .eq. 1) then - - call CG_action_bilinear (Au, Av, Du, Dv, Phi, Phisub, umask, vmask, hmask, & - H_node, visc, float_cond, G%bathyT, beta, G%areaT, is, ie, js, & - je, CS%density_ice/CS%density_ocean_avg) - - elseif (FE .eq. 2) then - - call CG_action_triangular (Au, Av, Du, Dv, umask, vmask, hmask, visc, visc_lo, & - beta, beta_lo, G%dxT, G%dyT, G%areaT, is, ie, js, je, isym) - endif - - - ! Au, Av valid region moves in by 1 - - if ( .not. CS%use_reproducing_sums) then - - - ! alpha_k = (Z \dot R) / (D \dot AD} - dot_p1 = 0 ; dot_p2 = 0 - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + Du(i,j)*Au(i,j) - endif - if (vmask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + Dv(i,j)*Av(i,j) - endif - enddo - enddo - call mpp_sum (dot_p1) ; call mpp_sum (dot_p2) - else - - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - - do j=jscq,jecq - do i=iscq,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + & - Zv(i,j) * Rv(i,j) - - if (umask(i,j) .eq. 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) - if (vmask(i,j) .eq. 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & - Dv(i,j) * Av(i,j) - enddo - enddo - - dot_p1 = reproducing_sum ( sum_vec, iscq, iecq, & - jscq, jecq ) - - dot_p2 = reproducing_sum ( sum_vec_2, iscq, iecq, & - jscq, jecq ) - - endif - - alpha_k = dot_p1/dot_p2 - - !### These should probably use explicit index notation so that they are - !### not applied outside of the valid range. - RWH - - ! u(:,:) = u(:,:) + alpha_k * Du(:,:) - ! v(:,:) = v(:,:) + alpha_k * Dv(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) .eq. 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) - if (vmask(i,j) .eq. 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) - enddo - enddo - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) .eq. 1) then - Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) - endif - if (vmask(i,j) .eq. 1) then - Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) - endif - enddo - enddo - -! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) -! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) .eq. 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) - if (vmask(i,j) .eq. 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) - enddo - enddo - - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) .eq. 1) then - Zu(i,j) = Ru (i,j) / DIAGu (i,j) - endif - if (vmask(i,j) .eq. 1) then - Zv(i,j) = Rv (i,j) / DIAGv (i,j) - endif - enddo - enddo - - ! R,u,v,Z valid region moves in by 1 - - if (.not. CS%use_reproducing_sums) then - - ! beta_k = (Z \dot R) / (Zold \dot Rold} - dot_p1 = 0 ; dot_p2 = 0 - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) - dot_p2 = dot_p2 + Zu_old(i,j)*Ru_old(i,j) - endif - if (vmask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) - dot_p2 = dot_p2 + Zv_old(i,j)*Rv_old(i,j) - endif - enddo - enddo - call mpp_sum (dot_p1) ; call mpp_sum (dot_p2) - - - else - - sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + & - Zv(i,j) * Rv(i,j) - - if (umask(i,j) .eq. 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) - if (vmask(i,j) .eq. 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & - Zv_old(i,j) * Rv_old(i,j) - enddo - enddo - - - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - dot_p2 = reproducing_sum ( sum_vec_2, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - - endif - - beta_k = dot_p1/dot_p2 - - -! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) -! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) - - do j=jsd,jed - do i=isd,ied - if (umask(i,j) .eq. 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) - if (vmask(i,j) .eq. 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) - enddo - enddo - - ! D valid region moves in by 1 - - dot_p1 = 0 - - if (.not. CS%use_reproducing_sums) then - - do j=jsumstart,jecq - do i=isumstart,iecq - if (umask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Ru(i,j)**2 - endif - if (vmask(i,j) .eq. 1) then - dot_p1 = dot_p1 + Rv(i,j)**2 - endif - enddo - enddo - call mpp_sum (dot_p1) - - else - - sum_vec(:,:) = 0.0 - - do j=JSUMSTART_INT_,jecq - do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Ru(i,j)**2 - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 - enddo - enddo - - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & - JSUMSTART_INT_, jecq ) - -! if (is_root_pe()) print *, dot_p1 -! if (is_root_pe()) print *, dot_p1a - - endif - - dot_p1 = sqrt (dot_p1) - -! if (mpp_pe () == 0) then -! print *,"|r|",dot_p1 -! endif - - if (dot_p1 .le. CS%cg_tolerance * resid0) then - iters = iter - conv_flag = 1 - exit - endif - - cg_halo = cg_halo - 1 - - if (cg_halo .eq. 0) then - ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u, v, G%domain, TO_ALL, BGRID_NE) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) - cg_halo = 3 - endif - - enddo ! end of CG loop - - do j=jsdq,jedq - do i=isdq,iedq - if (umask(i,j) .eq. 3) then - u(i,j) = u_bdry(i,j) - elseif (umask(i,j) .eq. 0) then - u(i,j) = 0 - endif - - if (vmask(i,j) .eq. 3) then - v(i,j) = v_bdry(i,j) - elseif (vmask(i,j) .eq. 0) then - v(i,j) = 0 - endif - enddo - enddo - - call pass_vector (u,v, G%domain, TO_ALL, BGRID_NE) - - if (conv_flag .eq. 0) then - iters = CS%cg_max_iterations - endif - -end subroutine ice_shelf_solve_inner - -subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h0 - real, dimension(:,:), intent(inout) :: h_after_uflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%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 - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, u_face_mask, u_flux_boundary_values - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - - character (len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - u_face_mask => CS%u_face_mask - u_flux_boundary_values => CS%u_flux_boundary_values - 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 - - do j=jsd+1,jed-1 - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries - - stencil(:) = -1 -! if (i+i_off .eq. G%domain%nihalo+G%domain%nihalo) - do i=is,ie - - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then - - if (i+i_off .eq. G%domain%nihalo+1) then - at_west_bdry=.true. - else - at_west_bdry=.false. - endif - - if (i+i_off .eq. G%domain%niglobal+G%domain%nihalo) then - at_east_bdry=.true. - else - at_east_bdry=.false. - endif - - if (hmask(i,j) .eq. 1) then - - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - - h_after_uflux(i,j) = h0(i,j) - - stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - - flux_diff_cell = 0 - - ! 1ST DO LEFT FACE - - if (u_face_mask (i-1,j) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i-1,j) / dxdyh - - else - - ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - - ! if (at_west_bdry .and. (i .eq. G%isc)) then - ! print *, j, u_face, stencil(-1) - ! endif - - if (u_face .gt. 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_west_bdry .AND. (hmask(i-1,j).eq.3)) then ! at western bdry but there is a thickness bdry condition, - ! and the stencil contains it - stencil (-1) = CS%thickness_boundary_values(i-1,j) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i-1,j) * hmask(i-2,j) .eq. 1) then ! h(i-2) and h(i-1) are valid - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(i-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i-2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) - - endif - - elseif (u_face .lt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - - else - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) - endif - endif - endif - endif - - ! NEXT DO RIGHT FACE - - ! get u-velocity at center of right face - - if (u_face_mask (i+1,j) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i+1,j) / dxdyh - - else - - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - - if (u_face .lt. 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - - if (at_east_bdry .AND. (hmask(i+1,j).eq.3)) then ! at eastern bdry but there is a thickness bdry condition, - ! and the stencil contains it - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh - - elseif (hmask(i+1,j) * hmask(i+2,j) .eq. 1) then ! h(i+2) and h(i+1) are valid - - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) - - endif - - elseif (u_face .gt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid - - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2)) then - flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell - - endif - - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then - - if (at_west_bdry .AND. (hmask(i-1,j) .EQ. 3)) then - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter (i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i-1,j) - elseif (u_face_mask (i-1,j) .eq. 4.) then - flux_enter (i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values (i-1,j) - endif - - if (at_east_bdry .AND. (hmask(i+1,j) .EQ. 3)) then - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i+1,j) .eq. 4.) then - flux_enter (i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values (i+1,j) - endif - - if ((i .eq. is) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i-1,j) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - - hmask(i,j) = 2 - elseif ((i .eq. ie) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i+1,j) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - - hmask(i,j) = 2 - - endif - - endif - - endif - - enddo ! i loop - - endif - - enddo ! j loop - -! write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_thickness_x - -subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_vflux, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h_after_uflux - real, dimension(:,:), intent(inout) :: h_after_vflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%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 - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, v_face_mask, v_flux_boundary_values - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - character(len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - v_face_mask => CS%v_face_mask - v_flux_boundary_values => CS%v_flux_boundary_values - 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 - - do i=isd+2,ied-2 - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries - - stencil(:) = -1 - - do j=js,je - - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then - - if (j+j_off .eq. G%domain%njhalo+1) then - at_south_bdry=.true. - else - at_south_bdry=.false. - endif - - if (j+j_off .eq. G%domain%njglobal+G%domain%njhalo) then - at_north_bdry=.true. - else - at_north_bdry=.false. - endif - - if (hmask(i,j) .eq. 1) then - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - h_after_vflux (i,j) = h_after_uflux (i,j) - - stencil (:) = h_after_uflux (i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff_cell = 0 - - ! 1ST DO south FACE - - if (v_face_mask (i,j-1) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j-1) / dxdyh - - else - - ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - - if (v_face .gt. 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_south_bdry .AND. (hmask(i,j-1).eq.3)) then ! at western bdry but there is a thickness bdry condition, - ! and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i,j-1) * hmask(i,j-2) .eq. 1) then ! h(j-2) and h(j-1) are valid - - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(j-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) - endif - - elseif (v_face .lt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - else - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - endif - - ! NEXT DO north FACE - - if (v_face_mask(i,j+1) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j+1) / dxdyh - - else - - ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - - if (v_face .lt. 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - - if (at_north_bdry .AND. (hmask(i,j+1).eq.3)) then ! at eastern bdry but there is a thickness bdry condition, - ! and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh - elseif (hmask(i,j+1) * hmask(i,j+2) .eq. 1) then ! h(j+2) and h(j+1) are valid - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) - endif - - elseif (v_face .gt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) - endif - endif - - endif - - endif - - h_after_vflux (i,j) = h_after_vflux (i,j) + flux_diff_cell - - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then - - if (at_south_bdry .AND. (hmask(i,j-1) .EQ. 3)) then - v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) - flux_enter (i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j-1) - elseif (v_face_mask(i,j-1) .eq. 4.) then - flux_enter (i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j-1) - endif - - if (at_north_bdry .AND. (hmask(i,j+1) .EQ. 3)) then - v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) - flux_enter (i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j+1) - elseif (v_face_mask(i,j+1) .eq. 4.) then - flux_enter (i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j+1) - endif - - if ((j .eq. js) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j-1) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - hmask (i,j) = 2 - elseif ((j .eq. je) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j+1) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - hmask (i,j) = 2 - endif - - endif - endif - enddo ! j loop - endif - enddo ! i loop - - !write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_thickness_y - -subroutine shelf_advance_front (CS, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, - ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary - - ! if any cells go from partial to complete, we then must set the thickness, update hmask accordingly, - ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells. - ! (it is highly unlikely there will not be any; in which case this will need to be rethought.) - - ! most likely there will only be one "overflow". if not, though, a pass_var of all relevant variables - ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through - ! many iterations - - ! when 3d advected scalars are introduced, they will be impacted by what is done here - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count, isym - integer :: i_off, j_off - integer :: iter_flag - type(ocean_grid_type), pointer :: G - real, dimension(:,:), pointer :: hmask, mass_shelf, area_shelf_h, u_face_mask, v_face_mask, h_shelf - real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux - integer, dimension(4) :: mapi, mapj, new_partial -! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace - real, dimension (:,:,:), pointer :: flux_enter_replace => NULL() - - G => CS%grid - h_shelf => CS%h_shelf - hmask => CS%hmask - mass_shelf => CS%mass_shelf - area_shelf_h => CS%area_shelf_h - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - i_off = G%idg_offset ; j_off = G%jdg_offset - rho = CS%density_ice - iter_count = 0 ; iter_flag = 1 - -! if (G%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 - mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 - - do while (iter_flag .eq. 1) - - iter_flag = 0 - - if (iter_count .gt. 0) then - flux_enter (:,:,:) = flux_enter_replace(:,:,:) - flux_enter_replace (:,:,:) = 0.0 - endif - - iter_count = iter_count + 1 - - ! if iter_count .ge. 3 then some halo updates need to be done... - - - - do j=jsc-1,jec+1 - - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then - - do i=isc-1,iec+1 - - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then - ! first get reference thickness by averaging over cells that are fluxing into this cell - n_flux = 0 - h_reference = 0.0 - tot_flux = 0.0 - - do k=1,2 - if (flux_enter(i,j,k) .gt. 0) then - n_flux = n_flux + 1 - h_reference = h_reference + h_shelf(i+2*k-3,j) - tot_flux = tot_flux + flux_enter(i,j,k) - flux_enter(i,j,k) = 0.0 - endif - enddo - - do k=1,2 - if (flux_enter(i,j,k+2) .gt. 0) then - n_flux = n_flux + 1 - h_reference = h_reference + h_shelf (i,j+2*k-3) - tot_flux = tot_flux + flux_enter(i,j,k+2) - flux_enter (i,j,k+2) = 0.0 - endif - enddo - - if (n_flux .gt. 0) then - dxdyh = G%areaT(i,j) - h_reference = h_reference / real(n_flux) - partial_vol = h_shelf (i,j) * area_shelf_h (i,j) + tot_flux - - if ((partial_vol / dxdyh) .eq. h_reference) then ! cell is exactly covered, no overflow - hmask (i,j) = 1 - h_shelf (i,j) = h_reference - area_shelf_h(i,j) = dxdyh - elseif ((partial_vol / dxdyh) .lt. h_reference) then - hmask (i,j) = 2 - ! mass_shelf (i,j) = partial_vol * rho - area_shelf_h (i,j) = partial_vol / h_reference - h_shelf (i,j) = h_reference - else - if (.not. associated (flux_enter_replace)) then - allocate ( flux_enter_replace (G%isd:G%ied,G%jsd:G%jed,1:4) ) - flux_enter_replace (:,:,:) = 0.0 - endif - - hmask (i,j) = 1 - area_shelf_h(i,j) = dxdyh - !h_temp (i,j) = h_reference - partial_vol = partial_vol - h_reference * dxdyh - - iter_flag = 1 - - n_flux = 0 ; new_partial (:) = 0 - - do k=1,2 - if (u_face_mask (i-2+k,j) .eq. 2) then - n_flux = n_flux + 1 - elseif (hmask (i+2*k-3,j) .eq. 0) then - n_flux = n_flux + 1 - new_partial (k) = 1 - endif - enddo - do k=1,2 - if (v_face_mask (i,j-2+k) .eq. 2) then - n_flux = n_flux + 1 - elseif (hmask (i,j+2*k-3) .eq. 0) then - n_flux = n_flux + 1 - new_partial (k+2) = 1 - endif - enddo - - if (n_flux .eq. 0) then ! there is nowhere to put the extra ice! - h_shelf(i,j) = h_reference + partial_vol / dxdyh - else - h_shelf(i,j) = h_reference - - do k=1,2 - if (new_partial(k) .eq. 1) & - flux_enter_replace (i+2*k-3,j,3-k) = partial_vol / real(n_flux) - enddo - do k=1,2 ! ### Combine these two loops? - if (new_partial(k+2) .eq. 1) & - flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) - enddo - endif - - endif ! Parital_vol test. - endif ! n_flux gt 0 test. - - endif - enddo ! j-loop - endif - enddo - - ! call mpp_max(iter_flag) - - enddo ! End of do while(iter_flag) loop - - call mpp_max(iter_count) - - if(is_root_pe() .and. (iter_count.gt.1)) print *, iter_count, "MAX ITERATIONS,ADVANCE FRONT" - - if (associated(flux_enter_replace)) DEALLOCATE(flux_enter_replace) - -end subroutine shelf_advance_front - -!> Apply a very simple calving law using a minimum thickness rule -subroutine ice_shelf_min_thickness_calve (CS, h_shelf, area_shelf_h,hmask) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), pointer :: G - integer :: i,j - - G => CS%grid - - do j=G%jsd,G%jed - do i=G%isd,G%ied -! if ((h_shelf(i,j) .lt. CS%min_thickness_simple_calve) .and. (hmask(i,j).eq.1) .and. & -! (CS%float_frac(i,j) .eq. 0.0)) then - if ((h_shelf(i,j) .lt. CS%min_thickness_simple_calve) .and. (area_shelf_h(i,j).gt. 0.)) then - h_shelf(i,j) = 0.0 - area_shelf_h(i,j) = 0.0 - hmask(i,j) = 0.0 - endif - enddo - enddo - -end subroutine ice_shelf_min_thickness_calve - -subroutine calve_to_mask (CS, h_shelf, area_shelf_h, hmask, calve_mask) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask, calve_mask - - type(ocean_grid_type), pointer :: G - integer :: i,j - - G => CS%grid - - if (CS%calve_to_mask) then - do j=G%jsc,G%jec - do i=G%isc,G%iec - if ((calve_mask(i,j) .eq. 0.0) .and. (hmask(i,j) .ne. 0.0)) then - h_shelf(i,j) = 0.0 - area_shelf_h(i,j) = 0.0 - hmask(i,j) = 0.0 - endif - enddo - enddo - endif - -end subroutine calve_to_mask - -subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:), intent(in) :: OD - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: TAUD_X, TAUD_Y - integer, intent(in) :: FE - -! driving stress! - -! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. -! they will sit on the BGrid, and so their size depends on whether the grid is symmetric -! -! Since this is a finite element solve, they will actually have the form \int \phi_i rho g h \nabla s -! -! OD -this is important and we do not yet know where (in MOM) it will come from. It represents -! "average" ocean depth -- and is needed to find surface elevation -! (it is assumed that base_ice = bed + OD) - -! FE : 1 if bilinear, 2 if triangular linear FE - - real, dimension (:,:), pointer :: D, & ! ocean floor depth - H, & ! ice shelf thickness - hmask, u_face_mask, v_face_mask, float_frac - real, dimension (SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation - BASE ! basal elevation of shelf/stream - character(1) :: procnum - - - real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec - integer :: i_off, j_off - - G => CS%grid - - isym = 0 - 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 - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo - is = iscq - (1-isym); js = jscq - (1-isym) - i_off = G%idg_offset ; j_off = G%jdg_offset - - D => G%bathyT - H => CS%h_shelf - float_frac => CS%float_frac - hmask => CS%hmask - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - rho = CS%density_ice - rhow = CS%density_ocean_avg - - call savearray2 ("H",H,CS%write_output_to_file) -! call savearray2 ("hmask",hmask,CS%write_output_to_file) - call savearray2 ("u_face_mask", CS%u_face_mask_boundary,CS%write_output_to_file) - call savearray2 ("umask", CS%umask,CS%write_output_to_file) - call savearray2 ("v_face_mask", CS%v_face_mask_boundary,CS%write_output_to_file) - call savearray2 ("vmask", CS%vmask,CS%write_output_to_file) - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - ! prelim - go through and calculate S - - ! or is this faster? - BASE(:,:) = -D(:,:) + OD(:,:) - S(:,:) = BASE(:,:) + H(:,:) - -! write (procnum,'(I1)') mpp_pe() - - do j=jsc-1,jec+1 - do i=isc-1,iec+1 - cnt = 0 - sx = 0 - sy = 0 - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) -! print *,dxh," ",dyh," ",dxdyh - - if (hmask(i,j) .eq. 1) then ! we are inside the global computational bdry, at an ice-filled cell - - ! calculate sx - if ((i+i_off) .eq. gisc) then ! at left computational bdry - if (hmask(i+1,j) .eq. 1) then - sx = (S(i+1,j)-S(i,j))/dxh - else - sx = 0 - endif - elseif ((i+i_off) .eq. giec) then ! at right computational bdry - if (hmask(i-1,j) .eq. 1) then - sx = (S(i,j)-S(i-1,j))/dxh - else - sx=0 - endif - else ! interior - if (hmask(i+1,j) .eq. 1) then - cnt = cnt+1 - sx = S(i+1,j) - else - sx = S(i,j) - endif - if (hmask(i-1,j) .eq. 1) then - cnt = cnt+1 - sx = sx - S(i-1,j) - else - sx = sx - S(i,j) - endif - if (cnt .eq. 0) then - sx=0 - else - sx = sx / (cnt * dxh) - endif - endif - - cnt = 0 - - ! calculate sy, similarly - if ((j+j_off) .eq. gjsc) then ! at south computational bdry - if (hmask(i,j+1) .eq. 1) then - sy = (S(i,j+1)-S(i,j))/dyh - else - sy = 0 - endif - elseif ((j+j_off) .eq. gjec) then ! at nprth computational bdry - if (hmask(i,j-1) .eq. 1) then - sy = (S(i,j)-S(i,j-1))/dyh - else - sy = 0 - endif - else ! interior - if (hmask(i,j+1) .eq. 1) then - cnt = cnt+1 - sy = S(i,j+1) - else - sy = S(i,j) - endif - if (hmask(i,j-1) .eq. 1) then - cnt = cnt+1 - sy = sy - S(i,j-1) - else - sy = sy - S(i,j) - endif - if (cnt .eq. 0) then - sy=0 - else - sy = sy / (cnt * dyh) - endif - endif - - - if (FE .eq. 1) then - - ! SW vertex - taud_x (i-1,j-1) = taud_x (i-1,j-1) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j-1) = taud_y(i-1,j-1) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! SE vertex - taud_x(i,j-1) = taud_x(i,j-1) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j-1) = taud_y(i,j-1) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! NW vertex - taud_x(i-1,j) = taud_x(i-1,j) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j) = taud_y(i-1,j) - .25 * rho * grav * H(i,j) * sy * dxdyh - - ! NE vertex - taud_x(i,j) = taud_x(i,j) - .25 * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j) = taud_y(i,j) - .25 * rho * grav * H(i,j) * sy * dxdyh - - - else - - ! SW vertex - taud_x(i-1,j-1) = taud_x(i-1,j-1) - (1./6) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j-1) = taud_y(i-1,j-1) - (1./6) * rho * grav * H(i,j) * sy * dxdyh - - ! SE vertex - taud_x(i,j-1) = taud_x(i,j-1) - (1./3) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j-1) = taud_y(i,j-1) - (1./3) * rho * grav * H(i,j) * sy * dxdyh - - ! NW vertex - taud_x(i-1,j) = taud_x(i-1,j) - (1./3) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i-1,j) = taud_y(i-1,j) - (1./3) * rho * grav * H(i,j) * sy * dxdyh - - ! NE vertex - taud_x(i,j) = taud_x(i,j) - (1./6) * rho * grav * H(i,j) * sx * dxdyh - taud_y(i,j) = taud_y(i,j) - (1./6) * rho * grav * H(i,j) * sy * dxdyh - - endif - - if (float_frac(i,j) .eq. 1) then - neumann_val = .5 * grav * (rho * H (i,j) ** 2 - rhow * D(i,j) ** 2) - else - neumann_val = .5 * grav * (1-rho/rhow) * rho * H(i,j) ** 2 - endif - - - if ((u_face_mask(i-1,j) .eq. 2) .OR. (hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2) ) then ! left face of the cell is at a stress boundary - ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated pressure on either side of the face - ! on the ice side, it is rho g h^2 / 2 - ! on the ocean side, it is rhow g (delta OD)^2 / 2 - ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation is not above the base of the - ! ice in the current cell - taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * dyh * neumann_val ! note negative sign is due to direction of normal vector - taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val - endif - - if ((u_face_mask(i,j) .eq. 2) .OR. (hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2) ) then ! right face of the cell is at a stress boundary - taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val - taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val - endif - - if ((v_face_mask(i,j-1) .eq. 2) .OR. (hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2) ) then ! south face of the cell is at a stress boundary - taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val - taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val - endif - - if ((v_face_mask(i,j) .eq. 2) .OR. (hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2) ) then ! north face of the cell is at a stress boundary - taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val ! note negative sign is due to direction of normal vector - taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val - endif - - endif - enddo - enddo - - -! call savearray2 ("Taux"//"p"//procnum,taud_x,CS%write_output_to_file) -! call savearray2 ("Tauy"//"p"//procnum,taud_y,CS%write_output_to_file) - -end subroutine calc_shelf_driving_stress - -subroutine init_boundary_values (CS, time, input_flux, input_thick, new_sim) - type(time_type), intent(in) :: Time - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: input_flux, input_thick - logical, optional :: new_sim - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - -! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will -! need to update those velocity points not *technically* in any -! computational domain -- if this function gets moves to another module, -! DO NOT TAKE THE RESTARTING BIT WITH IT - - real, dimension (:,:) , pointer :: thickness_boundary_values, & - u_boundary_values, & - v_boundary_values, & - u_face_mask, v_face_mask, hmask - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec - integer :: i_off, j_off - real :: A, n, ux, uy, vx, vy, eps_min, domain_width - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec -! iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq - isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed -! iegq = G%iegq ; jegq = G%jegq - i_off = G%idg_offset ; j_off = G%jdg_offset - - thickness_boundary_values => CS%thickness_boundary_values - u_boundary_values => CS%u_boundary_values ; v_boundary_values => CS%v_boundary_values - u_face_mask => CS%u_face_mask ; v_face_mask => CS%v_face_mask ; hmask => CS%hmask - - domain_width = CS%len_lat - - ! this loop results in some values being set twice but... eh. - - do j=jsd,jed - do i=isd,ied - -! if ((i .eq. 4) .AND. ((mpp_pe() .eq. 0) .or. (mpp_pe() .eq. 6))) then -! print *,hmask(i,j),i,j,mpp_pe() -! endif - - if (hmask(i,j) .eq. 3) then - thickness_boundary_values (i,j) = input_thick - endif - - if ((hmask(i,j) .eq. 0) .or. (hmask(i,j) .eq. 1) .or. (hmask(i,j) .eq. 2)) then - if ((i.le.iec).and.(i.ge.isc)) then - if (u_face_mask (i-1,j) .eq. 3) then - u_boundary_values (i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & - 1.5 * input_flux / input_thick - u_boundary_values (i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & - 1.5 * input_flux / input_thick - endif - endif - endif - - if (.not.(new_sim)) then - if (.not. G%symmetric) then - if (((i+i_off) .eq. (G%domain%nihalo+1)).and.(u_face_mask(i-1,j).eq.3)) then - CS%u_shelf (i-1,j-1) = u_boundary_values (i-1,j-1) - CS%u_shelf (i-1,j) = u_boundary_values (i-1,j) -! print *, u_boundary_values (i-1,j) - endif - if (((j+j_off) .eq. (G%domain%njhalo+1)).and.(v_face_mask(i,j-1).eq.3)) then - CS%u_shelf (i-1,j-1) = u_boundary_values (i-1,j-1) - CS%u_shelf (i,j-1) = u_boundary_values (i,j-1) - endif - endif - endif - enddo - enddo - -end subroutine init_boundary_values - -subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper, nu_lower, & - beta_upper, beta_lower, dxh, dyh, dxdyh, is, ie, js, je, isym) - -real, dimension (:,:), intent (inout) :: uret, vret -real, dimension (:,:), intent (in) :: u, v -real, dimension (:,:), intent (in) :: umask, vmask -real, dimension (:,:), intent (in) :: hmask, nu_upper, nu_lower, beta_upper, beta_lower -real, dimension (:,:), intent (in) :: dxh, dyh, dxdyh -integer, intent(in) :: is, ie, js, je, isym - -! the linear action of the matrix on (u,v) with triangular finite elements -! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -! but this may change pursuant to conversations with others -! -! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -! in order to make less frequent halo updates -! isym = 1 if grid is symmetric, 0 o.w. - - real :: ux, uy, vx, vy - integer :: i,j - - do i=is,ie - do j=js,je - - if (hmask(i,j) .eq. 1) then ! this cell's vertices contain degrees of freedom - - ux = (u(i,j-1)-u(i-1,j-1))/dxh(i,j) - vx = (v(i,j-1)-v(i-1,j-1))/dxh(i,j) - uy = (u(i-1,j)-u(i-1,j-1))/dyh(i,j) - vy = (v(i-1,j)-v(i-1,j-1))/dyh(i,j) - - if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - uret(i,j-1) = uret(i,j-1) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - vret(i,j-1) = vret(i,j-1) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - uret(i-1,j) = uret(i-1,j) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - vret(i-1,j) = vret(i-1,j) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - if (umask(i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - uret(i-1,j-1) = uret(i-1,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - vret(i-1,j-1) = vret(i-1,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - uret(i-1,j-1) = uret(i-1,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - u(i-1,j) + u(i,j-1)) - - vret(i-1,j-1) = vret(i-1,j-1) + & - beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - v(i-1,j) + v(i,j-1)) - endif - - - ux = (u(i,j)-u(i-1,j))/dxh(i,j) - vx = (v(i,j)-v(i-1,j))/dxh(i,j) - uy = (u(i,j)-u(i,j-1))/dyh(i,j) - vy = (v(i,j)-v(i,j-1))/dyh(i,j) - - if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - uret(i,j-1) = uret(i,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - vret(i,j-1) = vret(i,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - uret(i-1,j) = uret(i-1,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - vret(i-1,j) = vret(i-1,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - uret(i,j-1) = uret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j-1) = vret(i,j-1) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - if (umask(i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - uret(i,j) = uret(i,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - vret(i,j) = vret(i,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - uret(i,j) = uret(i,j) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - - vret(i,j) = vret(i,j) + & - beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - u(i-1,j) + u(i,j-1)) - endif - - endif - - enddo - enddo - -end subroutine CG_action_triangular - -subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & - nu, float_cond, D, beta, dxdyh, is, ie, js, je, dens_ratio) - -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (inout) :: uret, vret -real, dimension (:,:,:,:), pointer :: Phi -real, dimension (:,:,:,:,:,:),pointer :: Phisub -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: u, v -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: umask, vmask, H_node -real, dimension (:,:), intent (in) :: hmask, nu, float_cond, D, beta, dxdyh -real, intent(in) :: dens_ratio -integer, intent(in) :: is, ie, js, je - -! the linear action of the matrix on (u,v) with triangular finite elements -! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -! but this may change pursuant to conversations with others -! -! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -! in order to make less frequent halo updates -! isym = 1 if grid is symmetric, 0 o.w. - -! the linear action of the matrix on (u,v) with triangular finite elements -! Phi has the form -! Phi (i,j,k,q) - applies to cell i,j - - ! 3 - 4 - ! | | - ! 1 - 2 - -! Phi (i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q -! Phi (i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q -! Phi_k is equal to 1 at vertex k, and 0 at vertex l .ne. k, and bilinear - - real :: ux, vx, uy, vy, uq, vq, area, basel - integer :: iq, jq, iphi, jphi, i, j, ilq, jlq - real, dimension(2) :: xquad - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - - do j=js,je - do i=is,ie ; if (hmask(i,j) .eq. 1) then -! dxh = G%dxh(i,j) -! dyh = G%dyh(i,j) -! -! X(:,:) = geolonq (i-1:i,j-1:j) -! Y(:,:) = geolatq (i-1:i,j-1:j) -! -! call bilinear_shape_functions (X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - area = dxdyh(i,j) - - Ucontr=0 - do iq=1,2 ; do jq=1,2 - - - if (iq .eq. 2) then - ilq = 2 - else - ilq = 1 - endif - - if (jq .eq. 2) then - jlq = 2 - else - jlq = 1 - endif - - uq = u(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u(i,j-1) * xquad(iq) * xquad(3-jq) + & - u(i-1,j) * xquad(3-iq) * xquad(jq) + & - u(i,j) * xquad(iq) * xquad(jq) - - vq = v(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v(i,j-1) * xquad(iq) * xquad(3-jq) + & - v(i-1,j) * xquad(3-iq) * xquad(jq) + & - v(i,j) * xquad(iq) * xquad(jq) - - ux = u(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - u(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - u(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - u(i,j) * Phi(i,j,7,2*(jq-1)+iq) - - vx = v(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & - v(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & - v(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & - v(i,j) * Phi(i,j,7,2*(jq-1)+iq) - - uy = u(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - u(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - u(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - u(i,j) * Phi(i,j,8,2*(jq-1)+iq) - - vy = v(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & - v(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & - v(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & - v(i,j) * Phi(i,j,8,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + & - .25 * area * nu (i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + & - .25 * area * nu (i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - endif - - if (iq .eq. iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq .eq. jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (float_cond(i,j) .eq. 0) then - - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) - - endif - - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) - - endif - - endif - Ucontr(iphi,jphi) = Ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j) -! if((i.eq.27) .and. (j.eq.8) .and. (iphi.eq.1) .and. (jphi.eq.1)) print *, "grid", uq, .25 * area * uq * xquad(ilq) * xquad(jlq) - - !endif - enddo ; enddo - enddo ; enddo - - if (float_cond(i,j) .eq. 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = D(i,j) - Ucell(:,:) = u(i-1:i,j-1:j) ; Vcell(:,:) = v(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal_bilinear & - (Phisub, Hcell, Ucell, Vcell, area, basel, dens_ratio, Usubcontr, Vsubcontr, i, j) - do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) - endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) - !if ( (iphi.eq.1) .and. (jphi.eq.1)) print *, i,j, Usubcontr (iphi,jphi) * beta(i,j), " ", Ucontr(iphi,jphi) - endif - enddo ; enddo - endif - - endif - enddo ; enddo - -end subroutine CG_action_bilinear - -subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_ratio, Ucontr, Vcontr, iin, jin) - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension(2,2), intent(in) :: H,U,V - real, intent(in) :: DXDYH, D, dens_ratio - real, dimension(2,2), intent(inout) :: Ucontr, Vcontr - integer, optional, intent(in) :: iin, jin - - ! D = cellwise-constant bed elevation - - integer :: nsub, i, j, k, l, qx, qy, m, n, i_m, j_m - real :: subarea, hloc, uq, vq - - nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) - - - if (.not. present(iin)) then - i_m = -1 - else - i_m = iin - endif - - if (.not. present(jin)) then - j_m = -1 - else - j_m = jin - endif - - - do m=1,2 - do n=1,2 - do j=1,nsub - do i=1,nsub - do qx=1,2 - do qy = 1,2 - - hloc = Phisub(i,j,1,1,qx,qy)*H(1,1)+Phisub(i,j,1,2,qx,qy)*H(1,2)+& - Phisub(i,j,2,1,qx,qy)*H(2,1)+Phisub(i,j,2,2,qx,qy)*H(2,2) - - if (dens_ratio * hloc - D .gt. 0) then - !if (.true.) then - uq = 0 ; vq = 0 - do k=1,2 - do l=1,2 - !Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) - !Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) - uq = uq + Phisub(i,j,k,l,qx,qy) * U(k,l) ; vq = vq + Phisub(i,j,k,l,qx,qy) * V(k,l) - enddo - enddo - - Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * uq - Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * vq - - ! if ((i_m .eq. 27) .and. (j_m .eq. 8) .and. (m.eq.1) .and. (n.eq.1)) print *, "in subgrid", uq, Phisub(i,j,m,n,qx,qy) - - endif - - enddo - enddo - enddo - enddo - enddo - enddo - -end subroutine CG_action_subgrid_basal_bilinear - -subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(inout) :: u_diagonal, v_diagonal - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, pointer, dimension (:,:) :: umask, vmask, & - nu_lower, nu_upper, beta_lower, beta_upper, hmask - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, is, js, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - ux = 1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 1./dxh ; vy = 0./dyh - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 0./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - ux = 0./dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 0./dxh ; vy = 1./dyh - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = -1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = 0./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - ux = -1./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - endif - - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - ux = 1./ dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j) = u_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j) = u_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 1./ dxh ; vy = 1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j) = v_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j) = v_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_triangle - -subroutine matrix_diagonal_bilinear(CS, float_cond, H_node, dens_ratio, Phisub, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: H_node - real :: dens_ratio - real, dimension (:,:), intent(in) :: float_cond - real, dimension (:,:,:,:,:,:),pointer :: Phisub - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_diagonal, v_diagonal - - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, dimension (:,:), pointer :: umask, vmask, hmask, & - nu, beta - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, area, uq, vq, basel - real, dimension(8,4) :: Phi - real, dimension(4) :: X, Y - real, dimension(2) :: xquad - real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) .eq. 1) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - X(1:2) = G%geoLonBu (i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu (i-1:i,j) *1000 - Y(1:2) = G%geoLatBu (i-1:i,j-1) *1000 - Y(3:4) = G%geoLatBu (i-1:i,j)*1000 - - call bilinear_shape_functions (X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do iq=1,2 ; do jq=1,2 - - do iphi=1,2 ; do jphi=1,2 - - if (iq .eq. iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq .eq. jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - - ux = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - vx = 0. - vy = 0. - - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - uq = xquad(ilq) * xquad(jlq) - - if (float_cond(i,j) .eq. 0) then - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) - endif - - endif - - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - - vx = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - ux = 0. - uy = 0. - - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - vq = xquad(ilq) * xquad(jlq) - - if (float_cond(i,j) .eq. 0) then - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) - endif - - endif - enddo ; enddo - enddo ; enddo - if (float_cond(i,j) .eq. 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_diagonal_subgrid_basal_bilinear & - (Phisub, Hcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) - endif - enddo ; enddo - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_bilinear - -subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, Ucontr, Vcontr) - real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension(2,2), intent(in) :: H - real, intent(in) :: DXDYH, D, dens_ratio - real, dimension(2,2), intent(inout) :: Ucontr, Vcontr - - ! D = cellwise-constant bed elevation - - integer :: nsub, i, j, k, l, qx, qy, m, n - real :: subarea, hloc - - nsub = size(Phisub,1) - subarea = DXDYH / (nsub**2) - - do m=1,2 - do n=1,2 - do j=1,nsub - do i=1,nsub - do qx=1,2 - do qy = 1,2 - - hloc = Phisub(i,j,1,1,qx,qy)*H(1,1)+Phisub(i,j,1,2,qx,qy)*H(1,2)+& - Phisub(i,j,2,1,qx,qy)*H(2,1)+Phisub(i,j,2,2,qx,qy)*H(2,2) - - if (dens_ratio * hloc - D .gt. 0) then - Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - endif - - - enddo - enddo - enddo - enddo - enddo - enddo - -end subroutine CG_diagonal_subgrid_basal_bilinear - - -subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundary_contr) - - type(time_type), intent(in) :: Time - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(inout) :: u_boundary_contr, v_boundary_contr - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - - real, pointer, dimension (:,:) :: u_boundary_values, & - v_boundary_values, & - umask, vmask, hmask, & - nu_lower, nu_upper, beta_lower, beta_upper - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - u_boundary_values => CS%u_boundary_values - v_boundary_values => CS%v_boundary_values - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - domain_width = CS%len_lat - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then - - if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - ux = (u_boundary_values(i,j-1)-u_boundary_values(i-1,j-1))/dxh - vx = (v_boundary_values(i,j-1)-v_boundary_values(i-1,j-1))/dxh - uy = (u_boundary_values(i-1,j)-u_boundary_values(i-1,j-1))/dyh - vy = (v_boundary_values(i-1,j)-v_boundary_values(i-1,j-1))/dyh - - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - endif - - endif - - if ((umask(i,j) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - ux = (u_boundary_values(i,j)-u_boundary_values(i-1,j))/dxh - vx = (v_boundary_values(i,j)-v_boundary_values(i-1,j))/dxh - uy = (u_boundary_values(i,j)-u_boundary_values(i,j-1))/dyh - vy = (v_boundary_values(i,j)-v_boundary_values(i,j-1))/dyh - - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - - v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - u_boundary_values(i-1,j) + & - u_boundary_values(i,j-1)) - endif - - - endif - endif ; enddo ; enddo - -end subroutine apply_boundary_values_triangle - -subroutine apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, dens_ratio, u_boundary_contr, v_boundary_contr) - - type(time_type), intent(in) :: Time - real, dimension (:,:,:,:,:,:),pointer:: Phisub - type(ice_shelf_CS), pointer :: CS - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: H_node - real, dimension (:,:), intent (in) :: float_cond - real :: dens_ratio - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_boundary_contr, v_boundary_contr - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - - real, pointer, dimension (:,:) :: u_boundary_values, & - v_boundary_values, & - umask, vmask, & - nu, beta, hmask - real, dimension(8,4) :: Phi - real, dimension(4) :: X, Y - real, dimension(2) :: xquad - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, uq, vq, area, basel - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - u_boundary_values => CS%u_boundary_values - v_boundary_values => CS%v_boundary_values - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) .eq. 1) then - - ! process this cell if any corners have umask set to non-dirichlet bdry. - ! NOTE: vmask not considered, probably should be - - if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. & - (umask(i-1,j) .eq. 3) .OR. (umask(i,j) .eq. 3)) then - - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - X(1:2) = G%geoLonBu (i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu (i-1:i,j)*1000 - Y(1:2) = G%geoLatBu (i-1:i,j-1)*1000 - Y(3:4) = G%geoLatBu (i-1:i,j)*1000 - - call bilinear_shape_functions (X, Y, Phi, area) - - ! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - - - - do iq=1,2 ; do jq=1,2 - - uq = u_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - u_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & - u_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & - u_boundary_values(i,j) * xquad(iq) * xquad(jq) - - vq = v_boundary_values(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & - v_boundary_values(i,j-1) * xquad(iq) * xquad(3-jq) + & - v_boundary_values(i-1,j) * xquad(3-iq) * xquad(jq) + & - v_boundary_values(i,j) * xquad(iq) * xquad(jq) - - ux = u_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - u_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & - u_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & - u_boundary_values(i,j) * Phi(7,2*(jq-1)+iq) - - vx = v_boundary_values(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & - v_boundary_values(i,j-1) * Phi(3,2*(jq-1)+iq) + & - v_boundary_values(i-1,j) * Phi(5,2*(jq-1)+iq) + & - v_boundary_values(i,j) * Phi(7,2*(jq-1)+iq) - - uy = u_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - u_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & - u_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & - u_boundary_values(i,j) * Phi(8,2*(jq-1)+iq) - - vy = v_boundary_values(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & - v_boundary_values(i,j-1) * Phi(4,2*(jq-1)+iq) + & - v_boundary_values(i-1,j) * Phi(6,2*(jq-1)+iq) + & - v_boundary_values(i,j) * Phi(8,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 - - if (iq .eq. iphi) then - ilq = 2 - else - ilq = 1 - endif - - if (jq .eq. jphi) then - jlq = 2 - else - jlq = 1 - endif - - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - - - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) - - if (float_cond(i,j) .eq. 0) then - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) - endif - - endif - - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - - - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - - if (float_cond(i,j) .eq. 0) then - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) - endif - - endif - enddo ; enddo - enddo ; enddo - - if (float_cond(i,j) .eq. 1) then - Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) - Ucell(:,:) = u_boundary_values(i-1:i,j-1:j) ; Vcell(:,:) = v_boundary_values(i-1:i,j-1:j) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal_bilinear & - (Phisub, Hcell, Ucell, Vcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) - do iphi=1,2 ; do jphi = 1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & - Usubcontr(iphi,jphi) * beta (i,j) - endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & - Vsubcontr(iphi,jphi) * beta (i,j) - endif - enddo ; enddo - endif - endif - endif ; enddo ; enddo - -end subroutine apply_boundary_values_bilinear - -subroutine calc_shelf_visc_triangular (CS,u,v) - type(ice_shelf_CS), pointer :: CS - real, dimension(:,:), intent(inout) :: u, v - -! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -! an "upper" and "lower" triangular viscosity - -! also this subroutine updates the nonlinear part of the basal traction - -! this may be subject to change later... to make it "hybrid" - - real, pointer, dimension (:,:) :: nu_lower , & - nu_upper, & - beta_eff_lower, & - beta_eff_upper - real, pointer, dimension (:,:) :: H, &! thickness - hmask - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - G => CS%grid - - if (G%symmetric) then - isym = 1 - else - isym = 0 - endif - - 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 ; ied = G%isd ; jed = G%jsd - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc - is = iscq - (1-isym); js = jscq - (1-isym) - - A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - - H => CS%h_shelf - hmask => CS%hmask - nu_upper => CS%ice_visc_upper_tri - nu_lower => CS%ice_visc_lower_tri - beta_eff_upper => CS%taub_beta_eff_upper_tri - beta_eff_lower => CS%taub_beta_eff_lower_tri - - C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - do i=isd,ied - do j=jsd,jed - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (hmask (i,j) .eq. 1) then - ux = (u(i,j-1)-u(i-1,j-1)) / dxh - vx = (v(i,j-1)-v(i-1,j-1)) / dxh - uy = (u(i-1,j)-u(i-1,j-1)) / dyh - vy = (v(i-1,j)-v(i-1,j-1)) / dyh - - nu_lower(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - umid = 1./3 * (u(i-1,j-1)+u(i-1,j)+u(i,j-1)) - vmid = 1./3 * (v(i-1,j-1)+v(i-1,j)+v(i,j-1)) - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta_eff_lower (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - ux = (u(i,j)-u(i-1,j)) / dxh - vx = (v(i,j)-v(i-1,j)) / dxh - uy = (u(i,j)-u(i,j-1)) / dyh - vy = (u(i,j)-u(i,j-1)) / dyh - - nu_upper(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - umid = 1./3 * (u(i,j)+u(i-1,j)+u(i,j-1)) - vmid = 1./3 * (v(i,j)+v(i-1,j)+v(i,j-1)) - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta_eff_upper (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - endif - enddo - enddo - -end subroutine calc_shelf_visc_triangular - -subroutine calc_shelf_visc_bilinear (CS, u, v) - type(ice_shelf_CS), pointer :: CS - real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v - -! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -! an "upper" and "lower" triangular viscosity - -! also this subroutine updates the nonlinear part of the basal traction - -! this may be subject to change later... to make it "hybrid" - - real, pointer, dimension (:,:) :: nu, & - beta - real, pointer, dimension (:,:) :: H, &! thickness - hmask - - type(ocean_grid_type), pointer :: G - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - G => CS%grid - - isym=0 - 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 ; ied = G%ied ; jed = G%jed - iegq = G%iegB ; jegq = G%jegB - gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 - giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc - is = iscq - (1-isym); js = jscq - (1-isym) - - A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - H => CS%h_shelf - hmask => CS%hmask - nu => CS%ice_visc_bilinear - beta => CS%taub_beta_eff_bilinear - - do j=jsd+1,jed-1 - do i=isd+1,ied-1 - - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (hmask (i,j) .eq. 1) then - ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh) - vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh) - uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh) - vy = (v(i,j) - v(i,j-1) + v(i-1,j) - v(i-1,j-1)) / (2*dyh) - - nu(i,j) = .5 * A**(-1/n) * (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - - umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4 - vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4 - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - endif - enddo - enddo - -end subroutine calc_shelf_visc_bilinear - -subroutine update_OD_ffrac (CS, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) - type(ice_shelf_CS), pointer :: CS - real, dimension(CS%grid%isd:,CS%grid%jsd:) :: ocean_mass - integer,intent(in) :: counter - integer,intent(in) :: nstep_velocity - real,intent(in) :: time_step - real,intent(in) :: velocity_update_time_step - - type(ocean_grid_type), pointer :: G - integer :: isc, iec, jsc, jec, i, j - real :: threshold_col_depth, rho_ocean, inv_rho_ocean - - threshold_col_depth = CS%thresh_float_col_depth - - G=>CS%grid - - rho_ocean = CS%density_ocean_avg - inv_rho_ocean = 1./rho_ocean - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - do j=jsc,jec - do i=isc,iec - CS%OD_rt(i,j) = CS%OD_rt(i,j) + ocean_mass(i,j)*inv_rho_ocean - if (ocean_mass(i,j) > threshold_col_depth*rho_ocean) then - CS%float_frac_rt(i,j) = CS%float_frac_rt(i,j) + 1.0 - endif - enddo - enddo - - if (counter .eq. nstep_velocity) then - - do j=jsc,jec - do i=isc,iec - CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) / real(nstep_velocity)) -! if ((CS%float_frac(i,j) .gt. 0) .and. (CS%float_frac(i,j) .lt. 1)) then -! print *,"PARTLY GROUNDED", CS%float_frac(i,j),i,j,mpp_pe() -! endif - CS%OD_av(i,j) = CS%OD_rt(i,j) / real(nstep_velocity) - - CS%OD_rt(i,j) = 0.0 ; CS%float_frac_rt(i,j) = 0.0 - enddo - enddo - - call pass_var(CS%float_frac, G%domain) - call pass_var(CS%OD_av, G%domain) - - endif - -end subroutine update_OD_ffrac - -subroutine update_OD_ffrac_uncoupled (CS) - type(ice_shelf_CS), pointer :: CS - - type(ocean_grid_type), pointer :: G - integer :: i, j, iters, isd, ied, jsd, jed - real :: rhoi, rhow, OD - type(time_type) :: dummy_time - real,dimension(:,:),pointer :: OD_av, float_frac, h_shelf - - - G => CS%grid - rhoi = CS%density_ice - rhow = CS%density_ocean_avg - dummy_time = set_time (0,0) - OD_av => CS%OD_av - h_shelf => CS%h_shelf - float_frac => CS%float_frac - isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - -! print *,"rhow",rhow,"rho",rhoi - - do j=jsd,jed - do i=isd,ied - OD = G%bathyT(i,j) - rhoi/rhow * h_shelf (i,j) - if (OD.ge.0) then - ! ice thickness does not take up whole ocean column -> floating - OD_av (i,j) = OD - float_frac(i,j) = 0. - else - OD_av (i,j) = 0. - float_frac(i,j) = 1. - endif - enddo - enddo - - -end subroutine update_OD_ffrac_uncoupled - -subroutine bilinear_shape_functions (X, Y, Phi, area) - real, dimension(4), intent(in) :: X, Y - real, dimension(8,4), intent (inout) :: Phi - real, intent (out) :: area - -! X and Y must be passed in the form - ! 3 - 4 - ! | | - ! 1 - 2 - -! this subroutine calculates the gradients of bilinear basis elements that -! that are centered at the vertices of the cell. values are calculated at -! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) -! (ordered in same way as vertices) -! -! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j -! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j -! Phi_i is equal to 1 at vertex i, and 0 at vertex k .ne. i, and bilinear -! -! This should be a one-off; once per nonlinear solve? once per lifetime? -! ... will all cells have the same shape and dimension? - - real, dimension (4) :: xquad, yquad - integer :: node, qpoint, xnode, xq, ynode, yq - real :: a,b,c,d,e,f,xexp,yexp - - 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 - - a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) - b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) - - do node=1,4 - - xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) - - if (ynode .eq. 1) then - yexp = 1-yquad(qpoint) - else - yexp = yquad(qpoint) - endif - - if (1 .eq. xnode) then - xexp = 1-xquad(qpoint) - else - xexp = xquad(qpoint) - endif - - Phi (2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) - Phi (2*node,qpoint) = ( -c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) - - enddo - enddo - - area = quad_area (X,Y) - -end subroutine bilinear_shape_functions - - -subroutine bilinear_shape_functions_subgrid (Phisub, nsub) - real, dimension(nsub,nsub,2,2,2,2), intent(inout) :: Phisub - integer :: nsub - - ! 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 - ! in partial floatation - ! the array Phisub contains the values of \phi_i (where i is a node of the cell) - ! at quad point j - ! i think this general approach may not work for nonrectangular elements... - ! - - ! Phisub (i,j,k,l,q1,q2) - ! i: subgrid index in x-direction - ! j: subgrid index in y-direction - ! k: basis function x-index - ! l: basis function y-index - ! q1: quad point x-index - ! q2: quad point y-index - - ! e.g. k=1,l=1 => node 1 - ! q1=2,q2=1 => quad point 2 - - ! 3 - 4 - ! | | - ! 1 - 2 - - - - integer :: i, j, k, l, qx, qy, indx, indy - real,dimension(2) :: xquad - real :: x0, y0, x, y, val, fracx - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - fracx = 1.0/real(nsub) - - do j=1,nsub - do i=1,nsub - x0 = (i-1) * fracx ; y0 = (j-1) * fracx - do qx=1,2 - do qy=1,2 - x = x0 + fracx*xquad(qx) - y = y0 + fracx*xquad(qy) - do k=1,2 - do l=1,2 - val = 1.0 - if (k .eq. 1) then - val = val * (1.0-x) - else - val = val * x - endif - if (l .eq. 1) then - val = val * (1.0-y) - else - val = val * y - endif - Phisub (i,j,k,l,qx,qy) = val - enddo - enddo - enddo - enddo - enddo - enddo - -! print *, Phisub(1,1,2,2,1,1),Phisub(1,1,2,2,1,2),Phisub(1,1,2,2,2,1),Phisub(1,1,2,2,2,2) - - -end subroutine bilinear_shape_functions_subgrid - - -subroutine update_velocity_masks (CS) - type(ice_shelf_CS), pointer :: CS - - ! sets masks for velocity solve - ! ignores the fact that their might be ice-free cells - this only considers the computational boundary - - ! !!!!IMPORTANT!!!! relies on thickness mask - assumed that this is called after hmask has been updated (and halo-updated) - - integer :: isym, i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc, isc, jsc, iec, jec, k - integer :: i_off, j_off - type(ocean_grid_type), pointer :: G - real, dimension(:,:), pointer :: umask, vmask, u_face_mask, v_face_mask, hmask, u_face_mask_boundary, v_face_mask_boundary - - G => CS%grid - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - i_off = G%idg_offset ; j_off = G%jdg_offset - isd = G%isd ; jsd = G%jsd - iegq = G%iegB ; jegq = G%jegB - gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo - giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc - - umask => CS%umask - vmask => CS%vmask - u_face_mask => CS%u_face_mask - v_face_mask => CS%v_face_mask - u_face_mask_boundary => CS%u_face_mask_boundary - v_face_mask_boundary => CS%v_face_mask_boundary - hmask => CS%hmask - - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - isym = 0 - - umask (:,:) = 0 ; vmask (:,:) = 0 - u_face_mask (:,:) = 0 ; v_face_mask (:,:) = 0 - - if (G%symmetric) then - is = isd ; js = jsd - else - is = isd+1 ; js = jsd+1 - endif - - do j=js,G%jed - do i=is,G%ied - - if (hmask(i,j) .eq. 1) then - - umask(i-1:i,j-1:j) = 1. - vmask(i-1:i,j-1:j) = 1. - - do k=0,1 - - select case (int(u_face_mask_boundary(i-1+k,j))) - case (3) - umask(i-1+k,j-1:j)=3. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=3. - case (2) - u_face_mask(i-1+k,j)=2. - case (4) - umask(i-1+k,j-1:j)=0. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=4. - case (0) - umask(i-1+k,j-1:j)=0. - vmask(i-1+k,j-1:j)=0. - u_face_mask(i-1+k,j)=0. - case (1) ! stress free x-boundary - umask(i-1+k,j-1:j)=0. - case default - end select - enddo - - do k=0,1 - - select case (int(v_face_mask_boundary(i,j-1+k))) - case (3) - vmask(i-1:i,j-1+k)=3. - umask(i-1:i,j-1+k)=0. - v_face_mask(i,j-1+k)=3. - case (2) - v_face_mask(i,j-1+k)=2. - case (4) - umask(i-1:i,j-1+k)=0. - vmask(i-1:i,j-1+k)=0. - v_face_mask(i,j-1+k)=4. - case (0) - umask(i-1:i,j-1+k)=0. - vmask(i-1:i,j-1+k)=0. - u_face_mask(i,j-1+k)=0. - case (1) ! stress free y-boundary - vmask(i-1:i,j-1+k)=0. - case default - end select - enddo - - !if (u_face_mask_boundary(i-1,j).geq.0) then !left boundary - ! u_face_mask (i-1,j) = u_face_mask_boundary(i-1,j) - ! umask (i-1,j-1:j) = 3. - ! vmask (i-1,j-1:j) = 0. - !endif - - !if (j_off+j .eq. gjsc+1) then !bot boundary - ! v_face_mask (i,j-1) = 0. - ! umask (i-1:i,j-1) = 0. - ! vmask (i-1:i,j-1) = 0. - !elseif (j_off+j .eq. gjec) then !top boundary - ! v_face_mask (i,j) = 0. - ! umask (i-1:i,j) = 0. - ! vmask (i-1:i,j) = 0. - !endif - - if (i .lt. G%ied) then - if ((hmask(i+1,j) .eq. 0) & - .OR. (hmask(i+1,j) .eq. 2)) then - !right boundary or adjacent to unfilled cell - u_face_mask (i,j) = 2. - endif - endif - - if (i .gt. G%isd) then - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then - !adjacent to unfilled cell - u_face_mask (i-1,j) = 2. - endif - endif - - if (j .gt. G%jsd) then - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then - !adjacent to unfilled cell - v_face_mask (i,j-1) = 2. - endif - endif - - if (j .lt. G%jed) then - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then - !adjacent to unfilled cell - v_face_mask (i,j) = 2. - endif - endif - - - endif - - enddo - enddo - - ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update - ! so this subroutine must update its own symmetric part of the halo - - call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) - call pass_vector (umask,vmask,G%domain,TO_ALL,BGRID_NE) - -end subroutine update_velocity_masks - - -subroutine interpolate_H_to_B (CS, h_shelf, hmask, H_node) - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(in) :: h_shelf, hmask - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: H_node - - type(ocean_grid_type), pointer :: G - integer :: i, j, isc, iec, jsc, jec, num_h, k, l - real :: summ - - G => CS%grid - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - H_node(:,:) = 0.0 - - ! H_node is node-centered; average over all cells that share that node - ! if no (active) cells share the node then its value there is irrelevant - - do j=jsc-1,jec - do i=isc-1,iec - summ = 0.0 - num_h = 0 - do k=0,1 - do l=0,1 - if (hmask (i+k,j+l) .eq. 1.0) then - summ = summ + h_shelf (i+k,j+l) - num_h = num_h + 1 - endif - enddo - enddo - if (num_h .gt. 0) then - H_node(i,j) = summ / num_h - endif - enddo - enddo - - call pass_var(H_node, G%domain) - -end subroutine interpolate_H_to_B - -!> Deallocates all memory associated with this module -subroutine ice_shelf_end(CS) - type(ice_shelf_CS), pointer :: CS - - if (.not.associated(CS)) return - - deallocate(CS%mass_shelf) ; deallocate(CS%area_shelf_h) - deallocate(CS%t_flux) ; deallocate(CS%lprec) - deallocate(CS%salt_flux) - - deallocate(CS%tflux_shelf) ; deallocate(CS%tfreeze); - deallocate(CS%exch_vel_t) ; deallocate(CS%exch_vel_s) - - deallocate(CS%h_shelf) ; deallocate(CS%hmask) - - if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then - deallocate(CS%u_shelf) ; deallocate(CS%v_shelf) -!!! OVS !!! - deallocate(CS%t_shelf); deallocate(CS%tmask); - deallocate(CS%t_boundary_values) - deallocate(CS%u_boundary_values) ; deallocate(CS%v_boundary_values) - deallocate(CS%ice_visc_bilinear) - deallocate(CS%ice_visc_lower_tri) ; deallocate(CS%ice_visc_upper_tri) - deallocate(CS%u_face_mask) ; deallocate(CS%v_face_mask) - deallocate(CS%umask) ; deallocate(CS%vmask) - - deallocate(CS%taub_beta_eff_bilinear) - deallocate(CS%taub_beta_eff_upper_tri) - deallocate(CS%taub_beta_eff_lower_tri) - deallocate(CS%OD_rt) ; deallocate(CS%OD_av) - deallocate(CS%float_frac) ; deallocate(CS%float_frac_rt) - endif - - deallocate(CS) + deallocate(CS) end subroutine ice_shelf_end -subroutine savearray2(fname,A,flag) - -! print 2-D array to file - -! this is here strictly for debug purposes - -CHARACTER(*),intent(in) :: fname -! This change is to allow the code to compile with the GNU compiler. -! DOUBLE PRECISION,DIMENSION(:,:),intent(in) :: A -REAL, DIMENSION(:,:), intent(in) :: A -LOGICAL :: flag - -INTEGER :: M,N,i,j,iock,lh,FIN -CHARACTER(23000) :: ln -CHARACTER(17) :: sing -CHARACTER(9) :: STR -CHARACTER(7) :: FMT1 - -if (.NOT. flag) then - return -endif - -PRINT *,"WRITING ARRAY " // fname - -FIN=7 -M = size(A,1) -N = size(A,2) - -OPEN(unit=fin,FILE=fname,STATUS='REPLACE',ACCESS='SEQUENTIAL',& - ACTION='WRITE',IOSTAT=iock) - -IF(M .gt. 1300) THEN - WRITE(fin) 'SECOND DIMENSION TOO LARGE' - CLOSE(fin) - RETURN -END IF - -DO i=1,M - WRITE(ln,'(E17.9)') A(i,1) - DO j=2,N - WRITE(sing,'(E17.9)') A(i,j) - ln = TRIM(ln) // ' ' // TRIM(sing) - END DO - +!> This routine is for stepping a stand-alone ice shelf model without an ocean. +subroutine solo_time_step(CS, time_step, nsteps, Time, min_time_step_in) + type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure + real, intent(in) :: time_step !< The time interval for this update, in s. + integer, intent(inout) :: nsteps !< The running number of ice shelf steps. + type(time_type), intent(inout) :: Time !< The current model time + real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step in s. + + type(ocean_grid_type), pointer :: G => NULL() + type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe + !! the ice-shelf state + integer :: is, iec, js, jec, i, j + real :: time_step_remain + real :: time_step_int, min_time_step + character(len=240) :: mesg + 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. - IF(i.eq.1) THEN - - lh = LEN(TRIM(ln)) - - FMT1 = '(A' - - SELECT CASE (lh) - CASE(1:9) - WRITE(FMT1(3:3),'(I1)') lh - - CASE(10:99) - WRITE(FMT1(3:4),'(I2)') lh - - CASE(100:999) - WRITE(FMT1(3:5),'(I3)') lh - - CASE(1000:9999) - WRITE(FMT1(3:6),'(I4)') lh - - END SELECT - - FMT1 = TRIM(FMT1) // ')' - - END IF - - WRITE(UNIT=fin,IOSTAT=iock,FMT=TRIM(FMT1)) TRIM(ln) - - IF(iock .ne. 0) THEN - PRINT*,iock - END IF -END DO - -CLOSE(FIN) - -end subroutine savearray2 - - -subroutine solo_time_step (CS, time_step, n, Time, min_time_step_in) - type(ice_shelf_CS), pointer :: CS - real,intent(in) :: time_step - integer, intent(inout) :: n - type(time_type) :: Time - real,optional,intent(in) :: min_time_step_in - - type(ocean_grid_type), pointer :: G - integer :: is, iec, js, jec, i, j, ki, kj, iters - real :: ratio, min_ratio, time_step_remain, local_u_max, & - local_v_max, time_step_int, min_time_step,spy,dumtimeprint - real, dimension(:,:), pointer :: u_shelf, v_shelf, hmask, umask, vmask - logical :: flag - type (time_type) :: dummy - character(2) :: procnum - character(4) :: stepnum - - CS%velocity_update_sub_counter = CS%velocity_update_sub_counter + 1 - spy = 365 * 86400 G => CS%grid - u_shelf => CS%u_shelf - v_shelf => CS%v_shelf - hmask => CS%hmask - umask => CS%umask - vmask => CS%vmask - time_step_remain = time_step - if (.not. (present (min_time_step_in))) then - min_time_step = 1000 ! i think this is in seconds - this would imply ice is moving at ~1 meter per second - else - min_time_step=min_time_step_in - endif + ISS => CS%ISS is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec - ! NOTE: this relies on NE grid indexing - ! dumtimeprint=time_type_to_real(Time)/spy - if (is_root_pe()) print *, "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/spy - - do while (time_step_remain .gt. 0.0) - - min_ratio = 1.0e16 - n=n+1 - do j=js,jec - do i=is,iec - - local_u_max = 0 ; local_v_max = 0 - - if (hmask (i,j) .eq. 1.0) then - ! all 4 corners of the cell should have valid velocity values; otherwise something is wrong - ! this is done by checking that umask and vmask are nonzero at all 4 corners - do ki=1,2 ; do kj = 1,2 - - local_u_max = max (local_u_max, abs(u_shelf(i-1+ki,j-1+kj))) - local_v_max = max (local_v_max, abs(v_shelf(i-1+ki,j-1+kj))) - - enddo ; enddo - - ratio = min (G%areaT(i,j) / (local_u_max+1.0e-12), G%areaT(i,j) / (local_v_max+1.0e-12)) - min_ratio = min (min_ratio, ratio) - - endif - enddo ! j loop - enddo ! i loop - - ! solved velocities are in m/yr; we want m/s - - call mpp_min (min_ratio) - - time_step_int = min(CS%CFL_factor * min_ratio * (365*86400), time_step) - - if (time_step_int .lt. min_time_step) then - call MOM_error (FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep") - else - if (is_root_pe()) then - write(*,*) "Ice model timestep: ", time_step_int, " seconds" - endif - endif - - if (time_step_int .ge. time_step_remain) then - time_step_int = time_step_remain - time_step_remain = 0.0 - else - time_step_remain = time_step_remain - time_step_int - endif - - write (stepnum,'(I4)') CS%velocity_update_sub_counter - - call ice_shelf_advect (CS, time_step_int, CS%lprec, Time) - - if (mpp_pe() .eq. 7) then - call savearray2 ("hmask",CS%hmask,CS%write_output_to_file) -!!! OVS!!! -! call savearray2 ("tshelf",CS%t_shelf,CS%write_output_to_file) - endif - - ! if the last mini-timestep is a day or less, we cannot expect velocities to change by much. - ! do not update them - if (time_step_int .gt. 1000) then - call update_velocity_masks (CS) - -! call savearray2 ("Umask"//"p"//trim(procnum)//"_"//trim(stepnum),CS%umask,CS%write_output_to_file) -! call savearray2 ("Vmask"//"p"//trim(procnum)//"_"//trim(stepnum),CS%vmask,CS%write_output_to_file) - - call update_OD_ffrac_uncoupled (CS) - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, 1, iters, dummy) - endif - -!!! OVS!!! - call ice_shelf_temp (CS, time_step_int, CS%lprec, Time) - - call enable_averaging(time_step,Time,CS%diag) - if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, CS%area_shelf_h, CS%diag) - if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) - if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf,CS%h_shelf,CS%diag) - if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,CS%hmask,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_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_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%OD_av,CS%diag) - if (CS%id_float_frac_rt>0) call post_data(CS%id_float_frac_rt,CS%float_frac_rt,CS%diag) -!!! OVS!!! -! if (CS%id_t_mask > 0) - call post_data(CS%id_t_mask,CS%tmask,CS%diag) -! if (CS%id_t_shelf > 0) - call post_data(CS%id_t_shelf,CS%t_shelf,CS%diag) - - call disable_averaging(CS%diag) - - enddo - -end subroutine solo_time_step - -!!! OVS !!! -subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real,pointer,dimension(:,:),intent(in) :: melt_rate - type(time_type) :: Time - -! time_step: time step in sec -! melt_rate: basal melt rate in kg/m^2/s - -! 5/23/12 OVS -! Arguments: -! CS - A structure containing the ice shelf state - including current velocities -! t0 - an array containing temperature at the beginning of the call -! t_after_uflux - an array containing the temperature after advection in u-direction -! t_after_vflux - similar -! -! This subroutine takes the velocity (on the Bgrid) and timesteps (HT)_t = - div (uHT) + (adot Tsurd -bdot Tbot) once and then calculates T=HT/H -! -! The flux overflows are included here. That is because they will be used to advect 3D scalars -! into partial cells - - ! - ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given - ! cell across its boundaries. - ! ###Perhaps flux_enter should be changed into u-face and v-face - ! ###fluxes, which can then be used in halo updates, etc. - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - type(ocean_grid_type), pointer :: G - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2)) :: th_after_uflux, th_after_vflux, TH - real, dimension(size(CS%h_shelf,1),size(CS%h_shelf,2),4) :: flux_enter - integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec - real :: rho, spy, t_bd, Tsurf, adot - real, dimension(:,:), pointer :: hmask, Tbot - character(len=2) :: procnum - - hmask => CS%hmask - G => CS%grid - rho = CS%density_ice - spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. - - adot = 0.1/spy ! for now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later - Tbot =>CS%Tfreeze - Tsurf = -20.0 - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter (:,:,:) = 0.0 - - th_after_uflux (:,:) = 0.0 - th_after_vflux (:,:) = 0.0 - - do j=jsd,jed - do i=isd,ied - t_bd = CS%t_boundary_values(i,j) -! if (CS%hmask(i,j) .gt. 1) then - if ((CS%hmask(i,j) .eq. 3) .or. (CS%hmask(i,j) .eq. -2)) then - CS%t_shelf(i,j) = CS%t_boundary_values(i,j) - endif - enddo - enddo - - do j=jsd,jed - do i=isd,ied - TH (i,j) = CS%t_shelf(i,j)*CS%h_shelf (i,j) - enddo - enddo - - -! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var (h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! call disable_averaging(CS%diag) - - -! call enable_averaging(time_step,Time,CS%diag) -! call pass_var (h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) - - - - call ice_shelf_advect_temp_x (CS, time_step/spy, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y (CS, time_step/spy, th_after_uflux, th_after_vflux, flux_enter) - - do j=jsd,jed - do i=isd,ied -! if (CS%hmask(i,j) .eq. 1) then - if (CS%h_shelf(i,j) .gt. 0.0) then - CS%t_shelf (i,j) = th_after_vflux(i,j)/CS%h_shelf (i,j) - else - CS%t_shelf(i,j) = -10.0 - endif - enddo - enddo - - do j=jsd,jed - do i=isd,ied - t_bd = CS%t_boundary_values(i,j) -! if (CS%hmask(i,j) .gt. 1) then - if ((CS%hmask(i,j) .eq. 3) .or. (CS%hmask(i,j) .eq. -2)) then - CS%t_shelf(i,j) = t_bd -! CS%t_shelf(i,j) = -15.0 - endif - enddo - enddo - - do j=jsc,jec - do i=isc,iec - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - if (CS%h_shelf(i,j) .gt. 0.0) then -! CS%t_shelf (i,j) = CS%t_shelf (i,j) + time_step*(adot*Tsurf -melt_rate (i,j)*Tbot(i,j))/CS%h_shelf (i,j) - CS%t_shelf (i,j) = CS%t_shelf (i,j) + time_step*(adot*Tsurf -3/spy*Tbot(i,j))/CS%h_shelf (i,j) - else - ! the ice is about to melt away - ! in this case set thickness, area, and mask to zero - ! NOTE: not mass conservative - ! should maybe scale salt & heat flux for this cell - - CS%t_shelf(i,j) = -10.0 - CS%tmask(i,j) = 0.0 - endif - endif - enddo - enddo - - call pass_var(CS%t_shelf, G%domain) - call pass_var(CS%tmask, G%domain) - - if (CS%DEBUG) then - call hchksum (CS%t_shelf, "temp after front", G%HI, haloshift=3) + time_step_remain = time_step + if (present (min_time_step_in)) then + min_time_step = min_time_step_in + else + min_time_step = 1000.0 ! This is in seconds - at 1 km resolution it would imply ice is moving at ~1 meter per second endif -end subroutine ice_shelf_temp - - -subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h0 - real, dimension(:,:), intent(inout) :: h_after_uflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%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 - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, u_face_mask, u_flux_boundary_values,u_boundary_values,t_boundary - real :: u_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - - character (len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - u_face_mask => CS%u_face_mask - u_flux_boundary_values => CS%u_flux_boundary_values - u_boundary_values => CS%u_shelf -! h_boundaries => CS%h_shelf - t_boundary => CS%t_boundary_values - 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 - - do j=jsd+1,jed-1 - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries - - stencil(:) = -1 -! if (i+i_off .eq. G%domain%nihalo+G%domain%nihalo) - do i=is,ie - - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then - - if (i+i_off .eq. G%domain%nihalo+1) then - at_west_bdry=.true. - else - at_west_bdry=.false. - endif - - if (i+i_off .eq. G%domain%niglobal+G%domain%nihalo) then - at_east_bdry=.true. - else - at_east_bdry=.false. - endif - - if (hmask(i,j) .eq. 1) then - - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - - h_after_uflux(i,j) = h0(i,j) - - stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 - - flux_diff_cell = 0 - - ! 1ST DO LEFT FACE - - if (u_face_mask (i-1,j) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i-1,j) * & - t_boundary(i-1,j) / dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary(i-1,j) / dxdyh - - else - - ! get u-velocity at center of left face - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - - ! if (at_west_bdry .and. (i .eq. G%isc)) then - ! print *, j, u_face, stencil(-1) - ! endif - - if (u_face .gt. 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_west_bdry .AND. (hmask(i-1,j).eq.3)) then ! at western bdry but there is a thickness bdry condition, - ! and the stencil contains it - stencil (-1) = CS%t_boundary_values(i-1,j)*CS%h_shelf(i-1,j) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i-1,j) * hmask(i-2,j) .eq. 1) then ! h(i-2) and h(i-1) are valid - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(i-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i-2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) - - endif - - elseif (u_face .lt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - - else - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then - flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) - endif - endif - endif - endif - - ! NEXT DO RIGHT FACE - - ! get u-velocity at center of right face - - if (u_face_mask (i+1,j) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i+1,j) *& - t_boundary(i+1,j)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary (i+1,j)/ dxdyh - - else - - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - - if (u_face .lt. 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - - if (at_east_bdry .AND. (hmask(i+1,j).eq.3)) then ! at eastern bdry but there is a thickness bdry condition, - ! and the stencil contains it - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh - - elseif (hmask(i+1,j) * hmask(i+2,j) .eq. 1) then ! h(i+2) and h(i+1) are valid - - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) - - endif - - elseif (u_face .gt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid - - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - - else ! h(i+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(i+2) is not - - flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - - if ((hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2)) then - - flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell - - endif - - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then + write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) + call MOM_mesg("solo_time_step: "//mesg) - if (at_west_bdry .AND. (hmask(i-1,j) .EQ. 3)) then - u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter (i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i-1,j)*CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i-1,j) .eq. 4.) then - flux_enter (i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values (i-1,j)*t_boundary(i-1,j) -! flux_enter (i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary (i-1,j) -! assume no flux bc for temp - endif - - if (at_east_bdry .AND. (hmask(i+1,j) .EQ. 3)) then - u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i+1,j)*CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i+1,j) .eq. 4.) then - flux_enter (i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values (i+1,j) * t_boundary(i+1,j) -! assume no flux bc for temp -! flux_enter (i,j,2) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary (i+1,j) - endif - -! if ((i .eq. is) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i-1,j) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - -! hmask(i,j) = 2 -! elseif ((i .eq. ie) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i+1,j) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - -! hmask(i,j) = 2 - -! endif - - endif - - endif + do while (time_step_remain > 0.0) + nsteps = nsteps+1 - enddo ! i loop + ! If time_step is not too long, this is unnecessary. + time_step_int = min(ice_time_step_CFL(CS%dCS, ISS, G), time_step) + write (mesg,*) "Ice model timestep = ", time_step_int, " seconds" + if (time_step_int < min_time_step) then + call MOM_error(FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep "//mesg) + else + call MOM_mesg("solo_time_step: "//mesg) endif - enddo ! j loop - -! write (procnum,'(I1)') mpp_pe() - -end subroutine ice_shelf_advect_temp_x - -subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, flux_enter) - type(ice_shelf_CS), pointer :: CS - real, intent(in) :: time_step - real, dimension(:,:), intent(in) :: h_after_uflux - real, dimension(:,:), intent(inout) :: h_after_vflux - real, dimension(:,:,:), intent(inout) :: flux_enter - - ! use will be made of CS%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 - - ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary - ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) - ! - ! o--- (4) ---o - ! | | - ! (1) (2) - ! | | - ! o--- (3) ---o - ! - - integer :: isym, i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied - integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry - type(ocean_grid_type), pointer :: G - real, dimension(-2:2) :: stencil - real, dimension(:,:), pointer :: hmask, v_face_mask, v_flux_boundary_values,t_boundary,v_boundary_values - real :: v_face, & ! positive if out - flux_diff_cell, phi, dxh, dyh, dxdyh - character(len=1) :: debug_str, procnum - -! if (CS%grid%symmetric) then -! isym = 1 -! else -! isym = 0 -! endif - - isym = 0 - - G => CS%grid - hmask => CS%hmask - v_face_mask => CS%v_face_mask - v_flux_boundary_values => CS%v_flux_boundary_values - t_boundary => CS%t_boundary_values - v_boundary_values => CS%v_shelf - 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 - - do i=isd+2,ied-2 - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries - - stencil(:) = -1 - - do j=js,je - - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then - - if (j+j_off .eq. G%domain%njhalo+1) then - at_south_bdry=.true. - else - at_south_bdry=.false. - endif - if (j+j_off .eq. G%domain%njglobal+G%domain%njhalo) then - at_north_bdry=.true. - else - at_north_bdry=.false. - endif - - if (hmask(i,j) .eq. 1) then - dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - h_after_vflux (i,j) = h_after_uflux (i,j) - - stencil (:) = h_after_uflux (i,j-2:j+2) ! fine as long has ny_halo >= 2 - flux_diff_cell = 0 - - ! 1ST DO south FACE - - if (v_face_mask (i,j-1) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j-1) * t_boundary(i,j-1)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary (i,j-1) / dxdyh - - else - - ! get u-velocity at center of left face - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - - if (v_face .gt. 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available - - ! i may not cover all the cases.. but i cover the realistic ones - - if (at_south_bdry .AND. (hmask(i,j-1).eq.3)) then ! at western bdry but there is a thickness bdry condition, - ! and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh - - elseif (hmask(i,j-1) * hmask(i,j-2) .eq. 1) then ! h(j-2) and h(j-1) are valid - - phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) - - else ! h(j-1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j-2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) - endif - - elseif (v_face .lt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(-1))/2) - else - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then - flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) - endif - - endif - - endif - - endif - - ! NEXT DO north FACE - - if (v_face_mask(i,j+1) .eq. 4.) then - - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j+1) *& - t_boundary(i,j+1)/ dxdyh -! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary (i,j+1) / dxdyh - - else - - ! get u-velocity at center of right face - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - - if (v_face .lt. 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - - if (at_north_bdry .AND. (hmask(i,j+1).eq.3)) then ! at eastern bdry but there is a thickness bdry condition, - ! and the stencil contains it - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh - elseif (hmask(i,j+1) * hmask(i,j+2) .eq. 1) then ! h(j+2) and h(j+1) are valid - phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(1) - phi * (stencil(1)-stencil(0))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) - endif - - elseif (v_face .gt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid - phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & - (stencil(0) - phi * (stencil(0)-stencil(1))/2) - else ! h(j+1) is valid - ! (o.w. flux would most likely be out of cell) - ! but h(j+2) is not - flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then - flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) - endif - endif - - endif - - endif - - h_after_vflux (i,j) = h_after_vflux (i,j) + flux_diff_cell - - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then - - if (at_south_bdry .AND. (hmask(i,j-1) .EQ. 3)) then - v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - flux_enter (i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j-1)*CS%thickness_boundary_values(i,j-1) - elseif (v_face_mask(i,j-1) .eq. 4.) then - flux_enter (i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j-1)*t_boundary(i,j-1) -! assume no flux bc for temp -! flux_enter (i,j,3) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary (i,j-1) - - endif + if (time_step_int >= time_step_remain) then + time_step_int = time_step_remain + time_step_remain = 0.0 + else + time_step_remain = time_step_remain - time_step_int + endif - if (at_north_bdry .AND. (hmask(i,j+1) .EQ. 3)) then - v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - flux_enter (i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j+1)*CS%thickness_boundary_values(i,j+1) - elseif (v_face_mask(i,j+1) .eq. 4.) then - flux_enter (i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j+1)*t_boundary(i,j+1) -! assume no flux bc for temp -! flux_enter (i,j,4) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary (i,j+1) - endif + ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. + ! Do not update the velocities if the last step is very short. + update_ice_vel = ((time_step_int > min_time_step) .or. (time_step_int >= time_step)) + coupled_GL = .false. -! if ((j .eq. js) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j-1) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered - ! hmask (i,j) = 2 - ! elseif ((j .eq. je) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j+1) .eq. 1)) then - ! this is solely for the purposes of keeping the mask consistent while advancing the front without having - ! to call pass_var - if cell is empty and cell to left is ice-covered then this cell will become partly covered -! hmask (i,j) = 2 -! endif + call update_ice_shelf(CS%dCS, ISS, G, time_step_int, Time, must_update_vel=update_ice_vel) - endif - endif - enddo ! j loop - endif - enddo ! i loop + call enable_averaging(time_step,Time,CS%diag) + if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) + if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) + call disable_averaging(CS%diag) - !write (procnum,'(I1)') mpp_pe() + enddo -end subroutine ice_shelf_advect_temp_y +end subroutine solo_time_step !> \namespace mom_ice_shelf !! !! \section section_ICE_SHELF !! !! This module implements the thermodynamic aspects of ocean/ice-shelf -!! inter-actions, along with a crude placeholder for a later implementation of full -!! ice shelf dynamics, all using the MOM framework and coding style. +!! inter-actions using the MOM framework and coding style. !! !! Derived from code by Chris Little, early 2010. !! -!! NOTE: THERE ARE A NUMBER OF SUBROUTINES WITH "TRIANGLE" IN THE NAME; THESE -!! HAVE NOT BEEN TESTED AND SHOULD PROBABLY BE PHASED OUT -!! !! The ice-sheet dynamics subroutines do the following: !! initialize_shelf_mass - Initializes the ice shelf mass distribution. !! - Initializes h_shelf, h_mask, area_shelf_h @@ -6687,48 +1774,9 @@ end subroutine ice_shelf_advect_temp_y !! h_shelf and density_ice immediately afterwards. Possibly subroutine should be renamed !! update_shelf_mass - updates ice shelf mass via netCDF file !! USER_update_shelf_mass (TODO). -!! ice_shelf_solve_outer - Orchestrates the calls to calculate the shelf -!! - outer loop calls ice_shelf_solve_inner -!! stresses and checks for error tolerances. -!! Max iteration count for outer loop currently fixed at 100 iteration -!! - tolerance (and error evaluation) can be set through input file -!! - updates u_shelf, v_shelf, ice_visc_bilinear, taub_beta_eff_bilinear -!! ice_shelf_solve_inner - Conjugate Gradient solve of matrix solve for ice_shelf_solve_outer -!! - Jacobi Preconditioner - basically diagonal of matrix (not sure if it is effective at all) -!! - modifies u_shelf and v_shelf only -!! - max iteration count can be set through input file -!! - tolerance (and error evaluation) can be set through input file -!! (ISSUE: Too many mpp_sum calls?) -!! calc_shelf_driving_stress - Determine the driving stresses using h_shelf, (water) column thickness, bathymetry -!! - does not modify any permanent arrays -!! init_boundary_values - -!! bilinear_shape_functions - shape function for FEM solve using (convex) quadrilateral elements and bilinear nodal basis -!! calc_shelf_visc_bilinear - Glen's law viscosity and nonlinear sliding law (called by ice_shelf_solve_outer) -!! calc_shelf_visc_triangular - LET'S TAKE THIS OUT -!! apply_boundary_values_bilinear - same as CG_action_bilinear, but input is zero except for dirichlet bdry conds -!! apply_boundary_values_triangle - LET'S TAKE THIS OUT -!! CG_action_bilinear - Effect of matrix (that is never explicitly constructed) -!! on vector space of Degrees of Freedom (DoFs) in velocity solve -!! CG_action_triangular -LET'S TAKE THIS OUT -!! matrix_diagonal_bilinear - Returns the diagonal entries of a matrix for preconditioning. -!! (ISSUE: No need to use control structure - add arguments. -!! matrix_diagonal_triangle - LET'S TAKE THIS OUT -!! ice_shelf_advect - Given the melt rate and velocities, it advects the ice shelf THICKNESS -!! - modified h_shelf, area_shelf_h, hmask -!! (maybe should updater mass_shelf as well ???) -!! ice_shelf_advect_thickness_x, ice_shelf_advect_thickness_y - These -!! subroutines determine the mass fluxes through the faces. -!! (ISSUE: duplicative flux calls for shared faces?) -!! ice_shelf_advance_front - Iteratively determine the ice-shelf front location. -!! - IF ice_shelf_advect_thickness_x,y are modified to avoid -!! dupe face processing, THIS NEEDS TO BE MODIFIED TOO -!! as it depends on arrays modified in those functions -!! (if in doubt consult DNG) -!! update_velocity_masks - Controls which elements of u_shelf and v_shelf are considered DoFs in linear solve !! solo_time_step - called only in ice-only mode. !! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. currently mass_shelf is -!! updated immediately after ice_shelf_advect. -!! +!! updated immediately after ice_shelf_advect in fully dynamic mode. !! !! NOTES: be aware that hmask(:,:) has a number of functions; it is used for front advancement, !! for subroutines in the velocity solve, and for thickness boundary conditions (this last one may be removed). @@ -6737,11 +1785,6 @@ end subroutine ice_shelf_advect_temp_y !! Overall issues: Many variables need better documentation and units and the !! subgrid on which they are discretized. !! -!! DNG 4/09/11 : due to a misunderstanding (i confused a SYMMETRIC GRID -!! a SOUTHWEST GRID there is a variable called "isym" that appears -!! throughout in array loops. i am leaving it in for now, -!!though uniformly setting it to zero -!! !! \subsection section_ICE_SHELF_equations ICE_SHELF equations !! !! The three fundamental equations are: @@ -6770,134 +1813,4 @@ end subroutine ice_shelf_advect_temp_y !! Holland, David M., and Adrian Jenkins. Modeling thermodynamic ice-ocean interactions at the base of an ice shelf. !! Journal of Physical Oceanography 29.8 (1999): 1787-1800. - - -! GMM, I am putting all the commented functions below - -! subroutine add_shelf_flux_IOB(CS, state, forces, fluxes) -! ! type(ice_ocean_boundary_type), intent(inout) :: IOB -! type(ice_shelf_CS), intent(in) :: CS -! type(surface), intent(inout) :: state -! type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces -! type(forcing), intent(inout) :: fluxes - -! ! Arguments: -! ! (in) fluxes - A structure of surface fluxes that may be used. -! ! (in) visc - A structure containing vertical viscosities, bottom boundary -! ! layer properies, and related fields. -! ! (in) G - The ocean's grid structure. -! ! (in) CS - This module's control structure. -! !need to use visc variables -! !time step therm v. dynamic? -! real :: Irho0 ! The inverse of the mean density in m3 kg-1. -! real :: frac_area ! The fractional area covered by the ice shelf, nondim. -! real :: taux2, tauy2 ! The squared surface stresses, in Pa. -! real :: asu1, asu2 ! Ocean areas covered by ice shelves at neighboring u- -! real :: asv1, asv2 ! and v-points, in m2. -! integer :: i, j, is, ie, js, je, isd, ied, jsd, jed -! type(ocean_grid_type), pointer :: G - -! G=>CS%grid -! is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec -! isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - -! Irho0 = 1.0 / CS%Rho0 -! ! Determine ustar and the square magnitude of the velocity in the -! ! bottom boundary layer. Together these give the TKE source and -! ! vertical decay scale. -! if (CS%shelf_mass_is_dynamic) then -! do j=jsd,jed ; do i=isd,ied -! if (G%areaT(i,j) > 0.0) & -! fluxes%frac_shelf_h(i,j) = CS%area_shelf_h(i,j) / G%areaT(i,j) -! enddo ; enddo -! !do I=isd,ied-1 ; do j=isd,jed -! do j=jsd,jed ; do i=isd,ied-1 ! ### changed stride order; i->ied-1? -! forces%frac_shelf_u(I,j) = 0.0 -! if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & -! forces%frac_shelf_u(I,j) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i+1,j)) / & -! (G%areaT(i,j) + G%areaT(i+1,j))) -! forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & -! min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) -! enddo ; enddo -! do j=jsd,jed-1 ; do i=isd,ied ! ### change stride order; j->jed-1? -! !do i=isd,ied ; do J=isd,jed-1 -! forces%frac_shelf_v(i,J) = 0.0 -! if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & -! forces%frac_shelf_v(i,J) = ((CS%area_shelf_h(i,j) + CS%area_shelf_h(i,j+1)) / & -! (G%areaT(i,j) + G%areaT(i,j+1))) -! forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & -! min(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) -! enddo ; enddo -! call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) -! endif - -! if (CS%debug) then -! if (associated(state%taux_shelf)) then -! call uchksum(state%taux_shelf, "taux_shelf", G%HI, haloshift=0) -! endif -! if (associated(state%tauy_shelf)) then -! call vchksum(state%tauy_shelf, "tauy_shelf", G%HI, haloshift=0) -! endif -! endif - -! if (associated(state%taux_shelf) .and. associated(state%tauy_shelf)) then -! call pass_vector(state%taux_shelf, state%tauy_shelf, G%domain, TO_ALL, CGRID_NE) -! endif - -! do j=G%jsc,G%jec ; do i=G%isc,G%iec -! frac_area = fluxes%frac_shelf_h(i,j) -! if (frac_area > 0.0) then -! ! ### THIS SHOULD BE AN AREA WEIGHTED AVERAGE OF THE ustar_shelf POINTS. -! taux2 = 0.0 ; tauy2 = 0.0 -! asu1 = forces%frac_shelf_u(i-1,j) * (G%areaT(i-1,j) + G%areaT(i,j)) ! G%dxdy_u(i-1,j) -! asu2 = forces%frac_shelf_u(i,j) * (G%areaT(i,j) + G%areaT(i+1,j)) ! G%dxdy_u(i,j) -! asv1 = forces%frac_shelf_v(i,j-1) * (G%areaT(i,j-1) + G%areaT(i,j)) ! G%dxdy_v(i,j-1) -! asv2 = forces%frac_shelf_v(i,j) * (G%areaT(i,j) + G%areaT(i,j+1)) ! G%dxdy_v(i,j) -! if ((asu1 + asu2 > 0.0) .and. associated(state%taux_shelf)) & -! taux2 = (asu1 * state%taux_shelf(i-1,j)**2 + & -! asu2 * state%taux_shelf(i,j)**2 ) / (asu1 + asu2) -! if ((asv1 + asv2 > 0.0) .and. associated(state%tauy_shelf)) & -! tauy2 = (asv1 * state%tauy_shelf(i,j-1)**2 + & -! asv2 * state%tauy_shelf(i,j)**2 ) / (asv1 + asv2) -! fluxes%ustar_shelf(i,j) = MAX(CS%ustar_bg, sqrt(Irho0 * sqrt(taux2 + tauy2))) - -! if (CS%lprec(i,j) > 0.0) then -! fluxes%lprec(i,j) = fluxes%lprec(i,j) + frac_area*CS%lprec(i,j) -! ! Same for IOB%lprec -! else -! fluxes%evap(i,j) = fluxes%evap(i,j) + frac_area*CS%lprec(i,j) -! ! Same for -1*IOB%q_flux -! endif -! fluxes%sens(i,j) = fluxes%sens(i,j) - frac_area*CS%t_flux(i,j) -! ! Same for -1*IOB%t_flux -! ! fluxes%salt_flux(i,j) = fluxes%salt_flux(i,j) + frac_area * CS%salt_flux(i,j) -! ! ! Same for IOB%salt_flux. -! fluxes%p_surf(i,j) = fluxes%p_surf(i,j) + & -! frac_area * CS%g_Earth * CS%mass_shelf(i,j) -! ! Same for IOB%p -! if (associated(fluxes%p_surf_full)) fluxes%p_surf_full(i,j) = & -! fluxes%p_surf_full(i,j) + frac_area * CS%g_Earth * CS%mass_shelf(i,j) -! endif -! enddo ; enddo - -! if (CS%debug) then -! call hchksum(fluxes%ustar_shelf, "ustar_shelf", G%HI, haloshift=0) -! endif - -! ! If the shelf mass is changing, the forces%rigidity_ice_[uv] needs to be -! ! updated here. - -! if (CS%shelf_mass_is_dynamic) then -! do j=G%jsc,G%jec ; do i=G%isc-1,G%iec -! forces%rigidity_ice_u(I,j) = (CS%kv_ice / CS%density_ice) * & -! min(CS%mass_shelf(i,j), CS%mass_shelf(i+1,j)) -! enddo ; enddo - -! do j=G%jsc-1,G%jec ; do i=G%isc,G%iec -! forces%rigidity_ice_v(i,J) = (CS%kv_ice / CS%density_ice) * & -! min(CS%mass_shelf(i,j), CS%mass_shelf(i,j+1)) -! enddo ; enddo -! endif -! end subroutine add_shelf_flux_IOB - end module MOM_ice_shelf diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 new file mode 100644 index 0000000000..5cf01b10ac --- /dev/null +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -0,0 +1,4153 @@ +!> Implements the thermodynamic aspects of ocean / ice-shelf interactions, +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +module MOM_ice_shelf_dynamics + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_mediator_init, set_diag_mediator_grid +use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging +use MOM_domains, only : MOM_domains_init, clone_MOM_domain +use MOM_domains, only : pass_var, pass_vector, TO_ALL, CGRID_NE, BGRID_NE, CORNER +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_io, only : file_exists, slasher, MOM_read_data +use MOM_restart, only : register_restart_field, query_initialized +use MOM_restart, only : MOM_restart_CS +use MOM_time_manager, only : time_type, set_time, time_type_to_real +!MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary +use MOM_ice_shelf_state, only : ice_shelf_state +use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_checksums, only : hchksum, qchksum + +implicit none ; private + +#include + +public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf +public ice_time_step_CFL, ice_shelf_dyn_end +public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask + +!> The control structure for the ice shelf dynamics. +type, public :: ice_shelf_dyn_CS ; private + real, pointer, dimension(:,:) :: & + u_shelf => NULL(), & !< the zonal (?) velocity of the ice shelf/sheet, + !! in meters per second??? on q-points (B grid) + v_shelf => NULL(), & !< the meridional velocity of the ice shelf/sheet, + !! in m/s ?? on q-points (B grid) + + u_face_mask => NULL(), & !> masks for velocity boundary conditions + v_face_mask => NULL(), & !! on *C GRID* - this is because the FEM + !! cares about FACES THAT GET INTEGRATED OVER, + !! not vertices. Will represent boundary conditions + !! on computational boundary (or permanent boundary + !! between fast-moving and near-stagnant ice + !! FOR NOW: 1=interior bdry, 0=no-flow boundary, + !! 2=stress bdry condition, 3=inhomogeneous + !! dirichlet boundary, 4=flux boundary: at these + !! faces a flux will be specified which will + !! override velocities; a homogeneous velocity + !! condition will be specified (this seems to give + !! the solver less difficulty) + u_face_mask_bdry => NULL(), & + v_face_mask_bdry => NULL(), & + u_flux_bdry_val => NULL(), & + v_flux_bdry_val => NULL(), & + ! needed where u_face_mask is equal to 4, similary for v_face_mask + umask => NULL(), vmask => NULL(), & !< masks on the actual degrees of freedom (B grid) + !! 1=normal node, 3=inhomogeneous boundary node, + !! 0 - no flow node (will also get ice-free nodes) + calve_mask => NULL(), & !< a mask to prevent the ice shelf front from + !! advancing past its initial position (but it may + !! retreat) + t_shelf => NULL(), & !< Veritcally integrated temperature in the ice shelf/stream, in degC + !< on corner-points (B grid) + tmask => NULL(), & + ! masks for temperature boundary conditions ??? + ice_visc => NULL(), & + thickness_bdry_val => NULL(), & + u_bdry_val => NULL(), & + v_bdry_val => NULL(), & + h_bdry_val => NULL(), & + t_bdry_val => NULL(), & + + taub_beta_eff => NULL(), & ! nonlinear part of "linearized" basal stress - + ! exact form depends on basal law exponent + ! and/or whether flow is "hybridized" a la Goldberg 2011 + + OD_rt => NULL(), & !< A running total for calulating OD_av. + float_frac_rt => NULL(), & !< A running total for calculating float_frac. + OD_av => NULL(), & !< The time average open ocean depth, in m. + float_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column + !! thickness is below a threshold. + !! [if float_frac = 1 ==> grounded; obv. counterintuitive; might fix] + integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. + + real :: velocity_update_time_step !< The time in s to update the ice shelf velocity through the + !! nonlinear elliptic equation, or 0 to update every timestep. + ! DNGoldberg thinks this should be done no more often than about once a day + ! (maybe longer) because it will depend on ocean values that are averaged over + ! this time interval, and solving for the equiliabrated flow will begin to lose + ! meaning if it is done too frequently. + real :: elapsed_velocity_time !< The elapsed time since the ice velocies were last udated, in s. + + real :: g_Earth !< The gravitational acceleration in m s-2. + real :: density_ice !< A typical density of ice, in kg m-3. + + logical :: GL_regularize !< whether to regularize the floatation condition + !! at the grounding line a la Goldberg Holland Schoof 2009 + integer :: n_sub_regularize + !< partition of cell over which to integrate for + !! interpolated grounding line the (rectangular) is + !! divided into nxn equally-sized rectangles, over which + !! basal contribution is integrated (iterative quadrature) + logical :: GL_couple !< whether to let the floatation condition be + !!determined by ocean column thickness means update_OD_ffrac + !! will be called (note: GL_regularize and GL_couple + !! should be exclusive) + + real :: CFL_factor !< A factor used to limit subcycled advective timestep in uncoupled runs + !! i.e. dt <= CFL_factor * min(dx / u) + + real :: A_glen_isothermal + real :: n_glen + real :: eps_glen_min + real :: C_basal_friction + real :: n_basal_friction + real :: density_ocean_avg !< this does not affect ocean circulation OR thermodynamics + !! it is to estimate the gravitational driving force at the + !! shelf front(until we think of a better way to do it- + !! but any difference will be negligible) + real :: thresh_float_col_depth ! the water column depth over which the shelf if considered to be floating + logical :: moving_shelf_front + logical :: calve_to_mask + real :: min_thickness_simple_calve ! min. ice shelf thickness criteria for calving + + + real :: cg_tolerance + real :: nonlinear_tolerance + integer :: cg_max_iterations + integer :: nonlin_solve_err_mode ! 1: exit vel solve based on nonlin residual + ! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm + logical :: use_reproducing_sums !< use new reproducing sums of Bob & Alistair for global sums. + + ! ids for outputting intermediate thickness in advection subroutine (debugging) + !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 + + logical :: debug !< If true, write verbose checksums for debugging purposes + !! and use reproducible sums + logical :: module_is_initialized = .false. !< True if this module has been initialized. + + !>@{ + ! Diagnostic handles + integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & + id_float_frac = -1, id_col_thick = -1, id_OD_av = -1, & + id_u_mask = -1, id_v_mask = -1, id_t_mask = -1 + !>@} + ! ids for outputting intermediate thickness in advection subroutine (debugging) + !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to control diagnostic output. + +end type ice_shelf_dyn_CS + +contains + +!> used for flux limiting in advective subroutines Van Leer limiter (source: Wikipedia) +function slope_limiter(num, denom) + real, intent(in) :: num !< The numerator of the ratio used in the Van Leer slope limiter + real, intent(in) :: denom !< The denominator of the ratio used in the Van Leer slope limiter + real :: slope_limiter + real :: r + + if (denom == 0) then + slope_limiter = 0 + elseif (num*denom <= 0) then + slope_limiter = 0 + else + r = num/denom + slope_limiter = (r+abs(r))/(1+abs(r)) + endif + +end function slope_limiter + +!> Calculate area of quadrilateral. +function quad_area (X, Y) + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral. + real :: quad_area, p2, q2, a2, c2, b2, d2 + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + + p2 = (X(4)-X(1))**2 + (Y(4)-Y(1))**2 ; q2 = (X(3)-X(2))**2 + (Y(3)-Y(2))**2 + a2 = (X(3)-X(4))**2 + (Y(3)-Y(4))**2 ; c2 = (X(1)-X(2))**2 + (Y(1)-Y(2))**2 + b2 = (X(2)-X(4))**2 + (Y(2)-Y(4))**2 ; d2 = (X(3)-X(1))**2 + (Y(3)-Y(1))**2 + quad_area = .25 * sqrt(4*P2*Q2-(B2+D2-A2-C2)**2) + +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) + type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + 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), pointer :: restart_CS !< A pointer to the restart control structure. + + logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics + character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, register_ice_shelf_dyn_restarts: "// & + "called with an associated control structure.") + return + endif + allocate(CS) + + override_shelf_movement = .false. ; active_shelf_dynamics = .false. + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + default=.false., do_not_log=.true.) + if (shelf_mass_is_dynamic) then + call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & + "If true, user provided code specifies the ice-shelf \n"//& + "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) + active_shelf_dynamics = .not.override_shelf_movement + endif + + if (active_shelf_dynamics) then + allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%u_shelf(:,:) = 0.0 + allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB) ) ; CS%v_shelf(:,:) = 0.0 + allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 + allocate( CS%ice_visc(isd:ied,jsd:jed) ) ; CS%ice_visc(:,:) = 0.0 + allocate( CS%taub_beta_eff(isd:ied,jsd:jed) ) ; CS%taub_beta_eff(:,:) = 0.0 + allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 + allocate( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 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') + call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & + "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') + call register_restart_field(CS%t_shelf, "t_shelf", .true., restart_CS, & + "ice sheet/shelf vertically averaged temperature", "deg C") + call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & + "Average open ocean depth in a cell","m") + call register_restart_field(CS%float_frac, "float_frac", .true., restart_CS, & + "fractional degree of grounding", "nondim") + call register_restart_field(CS%ice_visc, "viscosity", .true., restart_CS, & + "Glens law ice viscosity", "m (seems wrong)") + call register_restart_field(CS%taub_beta_eff, "tau_b_beta", .true., restart_CS, & + "Coefficient of basal traction", "m (seems wrong)") + endif + +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, 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 + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. + logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise + !! has been started from a restart file. + logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether + !! a solo ice-sheet driver. + + !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 + + if (.not.associated(CS)) then + call MOM_error(FATAL, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn: "// & + "called with an associated control structure.") + return + endif + if (CS%module_is_initialized) then + call MOM_error(WARNING, "MOM_ice_shelf_dyn.F90, initialize_ice_shelf_dyn was "//& + "called with a control structure that has already been initialized.") + endif + CS%module_is_initialized = .true. + + CS%diag => diag ! ; CS%Time => Time + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & + "If true, write verbose debugging messages for the ice shelf.", & + default=debug) + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + "If true, the ice sheet mass can evolve with time.", & + default=.false.) + override_shelf_movement = .false. ; active_shelf_dynamics = .false. + if (shelf_mass_is_dynamic) then + call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", override_shelf_movement, & + "If true, user provided code specifies the ice-shelf \n"//& + "movement instead of the dynamic ice model.", default=.false., do_not_log=.true.) + active_shelf_dynamics = .not.override_shelf_movement + + call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & + "If true, regularize the floatation condition at the \n"//& + "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) + call get_param(param_file, mdl, "GROUNDING_LINE_INTERP_SUBGRID_N", CS%n_sub_regularize, & + "The number of sub-partitions of each cell over which to \n"//& + "integrate for the interpolated grounding line. Each cell \n"//& + "is divided into NxN equally-sized rectangles, over which the \n"//& + "basal contribution is integrated by iterative quadrature.", & + default=0) + call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & + "If true, let the floatation condition be determined by \n"//& + "ocean column thickness. This means that update_OD_ffrac \n"//& + "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & + default=.false., do_not_log=CS%GL_regularize) + if (CS%GL_regularize) CS%GL_couple = .false. + if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & + "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") + call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & + "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). \n"// & + "This is only used with an ice-only model.", default=0.25) + endif + call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & + "avg ocean density used in floatation cond", & + units="kg m-3", default=1035.) + if (active_shelf_dynamics) then + call get_param(param_file, mdl, "ICE_VELOCITY_TIMESTEP", CS%velocity_update_time_step, & + "seconds between ice velocity calcs", units="s", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & + "The gravitational acceleration of the Earth.", & + units="m s-2", default = 9.80) + + call get_param(param_file, mdl, "A_GLEN_ISOTHERM", CS%A_glen_isothermal, & + "Ice viscosity parameter in Glen's Law", & + units="Pa -1/3 a", default=9.461e-18) + call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & + "nonlinearity exponent in Glen's Law", & + units="none", default=3.) + call get_param(param_file, mdl, "MIN_STRAIN_RATE_GLEN", CS%eps_glen_min, & + "min. strain rate to avoid infinite Glen's law viscosity", & + units="a-1", default=1.e-12) + call get_param(param_file, mdl, "BASAL_FRICTION_COEFF", CS%C_basal_friction, & + "ceofficient in sliding law \tau_b = C u^(n_basal_friction)", & + units="Pa (m-a)-(n_basal_friction)", fail_if_missing=.true.) + call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_friction, & + "exponent in sliding law \tau_b = C u^(m_slide)", & + units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & + "A typical density of ice.", units="kg m-3", default=917.0) + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & + "tolerance in CG solver, relative to initial residual", default=1.e-6) + call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, & + "nonlin tolerance in iterative velocity solve",default=1.e-6) + call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & + "max iteratiions in CG solver", default=2000) + call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & + "min ocean thickness to consider ice *floating*; \n"// & + "will only be important with use of tides", & + units="m", default=1.e-3) + call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & + "Choose whether nonlin error in vel solve is based on nonlinear \n"// & + "residual (1) or relative change since last iteration (2)", default=1) + call get_param(param_file, mdl, "SHELF_DYN_REPRODUCING_SUMS", CS%use_reproducing_sums, & + "If true, use the reproducing extended-fixed-point sums in \n"//& + "the ice shelf dynamics solvers.", default=.true.) + + call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & + "Specify whether to advance shelf front (and calve).", & + default=.true.) + call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & + "If true, do not allow an ice shelf where prohibited by a mask.", & + default=.false.) + endif + call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", & + CS%min_thickness_simple_calve, & + "Min thickness rule for the VERY simple calving law",& + units="m", default=0.0) + + ! Allocate memory in the ice shelf dynamics control structure that was not + ! previously allocated for registration for restarts. + ! OVS vertically integrated Temperature + + if (active_shelf_dynamics) then + ! DNG + allocate( CS%u_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_bdry_val(:,:) = 0.0 + allocate( CS%v_bdry_val(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_bdry_val(:,:) = 0.0 + allocate( CS%t_bdry_val(isd:ied,jsd:jed) ) ; CS%t_bdry_val(:,:) = -15.0 + allocate( CS%h_bdry_val(isd:ied,jsd:jed) ) ; CS%h_bdry_val(:,:) = 0.0 + allocate( CS%thickness_bdry_val(isd:ied,jsd:jed) ) ; CS%thickness_bdry_val(:,:) = 0.0 + allocate( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 + allocate( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 + allocate( CS%u_face_mask_bdry(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_bdry(:,:) = -2.0 + allocate( CS%v_face_mask_bdry(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_bdry(:,:) = -2.0 + allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_bdry_val(:,:) = 0.0 + allocate( CS%v_flux_bdry_val(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_bdry_val(:,:) = 0.0 + allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 + allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 + allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 + + CS%OD_rt_counter = 0 + allocate( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 + allocate( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 + + if (CS%calve_to_mask) then + allocate( CS%calve_mask(isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 + endif + + CS%elapsed_velocity_time = 0.0 + + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif + + ! Take additional initialization steps, for example of dependent variables. + if (active_shelf_dynamics .and. .not.new_sim) then + ! this is unfortunately necessary; if grid is not symmetric the boundary values + ! of u and v are otherwise not set till the end of the first linear solve, and so + ! viscosity is not calculated correctly. + ! This has to occur after init_boundary_values or some of the arrays on the + ! right hand side have not been set up yet. + if (.not. G%symmetric) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i-1,j) = CS%u_bdry_val(i-1,j) + endif + if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i,j-1) = CS%u_bdry_val(i,j-1) + endif + enddo ; enddo + endif + + call pass_var(CS%OD_av,G%domain) + call pass_var(CS%float_frac,G%domain) + call pass_var(CS%ice_visc,G%domain) + call pass_var(CS%taub_beta_eff,G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) + endif + + if (active_shelf_dynamics) then + ! If we are calving to a mask, i.e. if a mask exists where a shelf cannot, read the mask from a file. + if (CS%calve_to_mask) then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") + + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "CALVING_MASK_FILE", IC_file, & + "The file with a mask for where calving might occur.", & + default="ice_shelf_h.nc") + call get_param(param_file, mdl, "CALVING_MASK_VARNAME", var_name, & + "The variable to use in masking calving.", & + default="area_shelf_h") + + filename = trim(inputdir)//trim(IC_file) + call log_param(param_file, mdl, "INPUTDIR/CALVING_MASK_FILE", filename) + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " calving mask file: Unable to open "//trim(filename)) + + call MOM_read_data(filename,trim(var_name),CS%calve_mask,G%Domain) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%calve_mask(i,j) > 0.0) CS%calve_mask(i,j) = 1.0 + enddo ; enddo + call pass_var(CS%calve_mask,G%domain) + endif + +! call init_boundary_values(CS, G, time, ISS%hmask, CS%input_flux, CS%input_thickness, new_sim) + + if (new_sim) then + call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf) + call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters, Time) + + 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) + endif + + ! Register diagnostics. + CS%id_u_shelf = register_diag_field('ocean_model','u_shelf',CS%diag%axesCu1, Time, & + 'x-velocity of ice', 'm yr-1') + CS%id_v_shelf = register_diag_field('ocean_model','v_shelf',CS%diag%axesCv1, Time, & + 'y-velocity of ice', 'm yr-1') + CS%id_u_mask = register_diag_field('ocean_model','u_mask',CS%diag%axesCu1, Time, & + 'mask for u-nodes', 'none') + CS%id_v_mask = register_diag_field('ocean_model','v_mask',CS%diag%axesCv1, Time, & + 'mask for v-nodes', 'none') +! CS%id_surf_elev = register_diag_field('ocean_model','ice_surf',CS%diag%axesT1, Time, & +! 'ice surf elev', 'm') + CS%id_float_frac = register_diag_field('ocean_model','ice_float_frac',CS%diag%axesT1, Time, & + 'fraction of cell that is floating (sort of)', 'none') + CS%id_col_thick = register_diag_field('ocean_model','col_thick',CS%diag%axesT1, Time, & + 'ocean column thickness passed to ice model', 'm') + CS%id_OD_av = register_diag_field('ocean_model','OD_av',CS%diag%axesT1, Time, & + 'intermediate ocean column thickness passed to ice model', 'm') + !CS%id_h_after_uflux = register_diag_field('ocean_model','h_after_uflux',CS%diag%axesh1, Time, & + ! 'thickness after u flux ', 'none') + !CS%id_h_after_vflux = register_diag_field('ocean_model','h_after_vflux',CS%diag%axesh1, Time, & + ! 'thickness after v flux ', 'none') + !CS%id_h_after_adv = register_diag_field('ocean_model','h_after_adv',CS%diag%axesh1, Time, & + ! 'thickness after front adv ', 'none') + +!!! OVS vertically integrated temperature + CS%id_t_shelf = register_diag_field('ocean_model','t_shelf',CS%diag%axesT1, Time, & + 'T of ice', 'oC') + CS%id_t_mask = register_diag_field('ocean_model','tmask',CS%diag%axesT1, Time, & + 'mask for T-nodes', 'none') + endif + +end subroutine initialize_ice_shelf_dyn + + +subroutine initialize_diagnostic_fields(CS, ISS, G, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + + integer :: i, j, iters, isd, ied, jsd, jed + real :: rhoi, rhow, OD + type(time_type) :: dummy_time + + rhoi = CS%density_ice + rhow = CS%density_ocean_avg + dummy_time = set_time (0,0) + isd=G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed + do i=isd,ied + OD = G%bathyT(i,j) - rhoi/rhow * ISS%h_shelf(i,j) + if (OD >= 0) then + ! ice thickness does not take up whole ocean column -> floating + CS%OD_av(i,j) = OD + CS%float_frac(i,j) = 0. + else + CS%OD_av(i,j) = 0. + CS%float_frac(i,j) = 1. + endif + enddo + enddo + + call ice_shelf_solve_outer(CS, ISS, G, CS%u_shelf, CS%v_shelf, iters, dummy_time) + +end subroutine initialize_diagnostic_fields + +!> This function returns the global maximum timestep that can be taken based on the current +!! ice velocities. Because it involves finding a global minimum, it can be suprisingly expensive. +function ice_time_step_CFL(CS, ISS, G) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real :: ice_time_step_CFL !< The maximum permitted timestep, in s, based on the ice velocities. + + real :: ratio, min_ratio + real :: local_u_max, local_v_max + integer :: i, j + + min_ratio = 1.0e16 ! This is just an arbitrary large value. + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then + local_u_max = max(abs(CS%u_shelf(i,j)), abs(CS%u_shelf(i+1,j+1)), & + abs(CS%u_shelf(i+1,j)), abs(CS%u_shelf(i,j+1))) + local_v_max = max(abs(CS%v_shelf(i,j)), abs(CS%v_shelf(i+1,j+1)), & + abs(CS%v_shelf(i+1,j)), abs(CS%v_shelf(i,j+1))) + + ratio = min(G%areaT(i,j) / (local_u_max+1.0e-12), G%areaT(i,j) / (local_v_max+1.0e-12)) + min_ratio = min(min_ratio, ratio) + endif ; enddo ; enddo ! i- and j- loops + + call min_across_PEs(min_ratio) + + ! solved velocities are in m/yr; we want time_step_int in seconds + ice_time_step_CFL = CS%CFL_factor * min_ratio * (365*86400) + +end function ice_time_step_CFL + +!> This subroutine updates the ice shelf velocities, mass, stresses and properties due to the +!! ice shelf dynamics. +subroutine update_ice_shelf(CS, ISS, G, time_step, Time, ocean_mass, coupled_grounding, must_update_vel) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< time step in sec + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G)), & + optional, intent(in) :: ocean_mass !< If present this is the mass puer unit area + !! of the ocean in kg m-2. + logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is + !! determined by coupled ice-ocean dynamics + logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. + + integer :: iters + logical :: update_ice_vel, coupled_GL + + update_ice_vel = .false. + if (present(must_update_vel)) update_ice_vel = must_update_vel + + 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, 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, CS%u_shelf, CS%v_shelf, iters, Time) + endif + + call ice_shelf_temp(CS, ISS, G, time_step, ISS%water_flux, Time) + + if (update_ice_vel) then + call enable_averaging(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_float_frac > 0) call post_data(CS%id_float_frac,CS%float_frac,CS%diag) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av,CS%OD_av,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_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + + call disable_averaging(CS%diag) + + CS%elapsed_velocity_time = 0.0 + endif + +end subroutine update_ice_shelf + +!> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. +!! Additionally, it will update the volume of ice in partially-filled cells, and update +!! hmask accordingly +subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< time step in sec + type(time_type), intent(in) :: Time !< The current model time + +! time_step: time step in sec + +! 3/8/11 DNG +! Arguments: +! CS - A structure containing the ice shelf state - including current velocities +! h0 - an array containing the thickness at the beginning of the call +! h_after_uflux - an array containing the thickness after advection in u-direction +! h_after_vflux - similar +! +! This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. +! ADDITIONALLY, it will update the volume of ice in partially-filled cells, and update +! hmask accordingly +! +! The flux overflows are included here. That is because they will be used to advect 3D scalars +! into partial cells + + ! + ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given + ! cell across its boundaries. + ! ###Perhaps flux_enter should be changed into u-face and v-face + ! ###fluxes, which can then be used in halo updates, etc. + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real :: rho, spy, thick_bd + + rho = CS%density_ice + spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + flux_enter(:,:,:) = 0.0 + + h_after_uflux(:,:) = 0.0 + h_after_vflux(:,:) = 0.0 + ! call MOM_mesg("MOM_ice_shelf.F90: ice_shelf_advect called") + + do j=jsd,jed + do i=isd,ied + thick_bd = CS%thickness_bdry_val(i,j) + if (thick_bd /= 0.0) then + ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) + endif + enddo + enddo + + call ice_shelf_advect_thickness_x(CS, G, time_step/spy, ISS%hmask, ISS%h_shelf, h_after_uflux, flux_enter) + +! call enable_averaging(time_step,Time,CS%diag) + ! call pass_var(h_after_uflux, G%domain) +! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) +! call disable_averaging(CS%diag) + + call ice_shelf_advect_thickness_y(CS, G, time_step/spy, ISS%hmask, h_after_uflux, h_after_vflux, flux_enter) + +! call enable_averaging(time_step,Time,CS%diag) +! call pass_var(h_after_vflux, G%domain) +! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) +! call disable_averaging(CS%diag) + + do j=jsd,jed + do i=isd,ied + if (ISS%hmask(i,j) == 1) ISS%h_shelf(i,j) = h_after_vflux(i,j) + enddo + enddo + + if (CS%moving_shelf_front) then + call shelf_advance_front(CS, ISS, G, flux_enter) + if (CS%min_thickness_simple_calve > 0.0) then + call ice_shelf_min_thickness_calve(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, & + CS%min_thickness_simple_calve) + endif + if (CS%calve_to_mask) then + call calve_to_mask(G, ISS%h_shelf, ISS%area_shelf_h, ISS%hmask, CS%calve_mask) + endif + endif + + !call enable_averaging(time_step,Time,CS%diag) + !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) + !call disable_averaging(CS%diag) + + !call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice) + + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + +end subroutine ice_shelf_advect + +subroutine ice_shelf_solve_outer(CS, ISS, G, u, v, 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 + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u !< The zonal ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v !< The meridional ice shelf velocity at vertices, in m/year + integer, intent(out) :: iters !< The number of iterations used in the solver. + type(time_type), intent(in) :: Time !< The current model time + + real, dimension(SZDIB_(G),SZDJB_(G)) :: TAUDX, TAUDY, u_prev_iterate, v_prev_iterate, & + u_bdry_cont, v_bdry_cont, Au, Av, err_u, err_v, & + u_last, v_last, H_node + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice + ! shelf is floating: 0 if floating, 1 if not. + integer :: conv_flag, i, j, k,l, iter + integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, isumstart, jsumstart, nodefloat, nsub + real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi, rhow + real, pointer, dimension(:,:,:,:) :: Phi => NULL() + real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() + real, dimension(8,4) :: Phi_temp + real, dimension(2,2) :: X,Y + character(2) :: iternum + character(2) :: numproc + + ! for GL interpolation - need to make this a readable parameter + nsub = CS%n_sub_regularize + + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + rhoi = CS%density_ice + rhow = CS%density_ocean_avg + + TAUDX(:,:) = 0.0 ; TAUDY(:,:) = 0.0 + u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 + Au(:,:) = 0.0 ; Av(:,:) = 0.0 + + ! need to make these conditional on GL interpolation + float_cond(:,:) = 0.0 ; H_node(:,:)=0 + allocate(Phisub (nsub,nsub,2,2,2,2)) ; Phisub = 0.0 + + isumstart = G%isc + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) isumstart = G%iscB + + jsumstart = G%jsc + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB + + call calc_shelf_driving_stress(CS, ISS, G, TAUDX, TAUDY, CS%OD_av) + + ! 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 + ! floatation condition is estimated by assuming topography is cellwise constant + ! and H is bilinear in a cell; floating where rho_i/rho_w * H_node + D is nonpositive + + ! need to make this conditional on GL interp + + if (CS%GL_regularize) then + + call interpolate_H_to_B(G, ISS%h_shelf, ISS%hmask, H_node) + + do j=G%jsc,G%jec + do i=G%isc,G%iec + nodefloat = 0 + do k=0,1 + do l=0,1 + if ((ISS%hmask(i,j) == 1) .and. & + (rhoi/rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) <= 0)) then + nodefloat = nodefloat + 1 + endif + enddo + enddo + if ((nodefloat > 0) .and. (nodefloat < 4)) then + float_cond(i,j) = 1.0 + CS%float_frac(i,j) = 1.0 + endif + enddo + enddo + + call pass_var(float_cond, G%Domain) + + call bilinear_shape_functions_subgrid(Phisub, nsub) + + endif + + ! make above conditional + + u_prev_iterate(:,:) = u(:,:) + v_prev_iterate(:,:) = v(:,:) + + ! must prepare phi + allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:) = 0.0 + + do j=jsd,jed ; do i=isd,ied + if (((i > isd) .and. (j > jsd))) then + X(:,:) = G%geoLonBu(i-1:i,j-1:j)*1000 + Y(:,:) = G%geoLatBu(i-1:i,j-1:j)*1000 + else + X(2,:) = G%geoLonBu(i,j)*1000 + X(1,:) = G%geoLonBu(i,j)*1000-G%dxT(i,j) + Y(:,2) = G%geoLatBu(i,j)*1000 + Y(:,1) = G%geoLatBu(i,j)*1000-G%dyT(i,j) + endif + + call bilinear_shape_functions(X, Y, Phi_temp, area) + Phi(i,j,:,:) = Phi_temp + enddo ; enddo + + call calc_shelf_visc(CS, ISS, G, u, v) + + call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%taub_beta_eff, G%domain) + + ! 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%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) + enddo ; enddo + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + rhoi/rhow, u_bdry_cont, v_bdry_cont) + + Au(:,:) = 0.0 ; Av(:,:) = 0.0 + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) + + err_init = 0 ; err_tempu = 0; err_tempv = 0 + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) + endif + if (err_tempv >= err_init) then + err_init = err_tempv + endif + enddo + enddo + + call max_across_PEs(err_init) + + if (is_root_pe()) print *,"INITIAL nonlinear residual: ",err_init + + u_last(:,:) = u(:,:) ; v_last(:,:) = v(:,:) + + !! begin loop + + do iter=1,100 + + call ice_shelf_solve_inner(CS, ISS, G, u, v, TAUDX, TAUDY, H_node, float_cond, & + ISS%hmask, conv_flag, iters, time, Phi, Phisub) + + if (CS%DEBUG) then + call qchksum(u, "u shelf", G%HI, haloshift=2) + call qchksum(v, "v shelf", G%HI, haloshift=2) + endif + + if (is_root_pe()) print *,"linear solve done",iters," iterations" + + call calc_shelf_visc(CS, ISS, G, u, v) + call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%taub_beta_eff, G%domain) + + ! 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%taub_beta_eff(i,j) = CS%taub_beta_eff(i,j) * CS%float_frac(i,j) + enddo ; enddo + + u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + rhoi/rhow, u_bdry_cont, v_bdry_cont) + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, G%areaT, & + G, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) + + err_max = 0 + + if (CS%nonlin_solve_err_mode == 1) then + + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) + endif + if (err_tempv >= err_max) then + err_max = err_tempv + endif + enddo + enddo + + call max_across_PEs(err_max) + + elseif (CS%nonlin_solve_err_mode == 2) then + + max_vel = 0 ; tempu = 0 ; tempv = 0 + + do j=jsumstart,G%jecB + do i=isumstart,G%iecB + if (CS%umask(i,j) == 1) then + err_tempu = ABS (u_last(i,j)-u(i,j)) + tempu = u(i,j) + endif + if (CS%vmask(i,j) == 1) then + err_tempv = MAX(ABS (v_last(i,j)- v(i,j)), err_tempu) + tempv = SQRT(v(i,j)**2+tempu**2) + endif + if (err_tempv >= err_max) then + err_max = err_tempv + endif + if (tempv >= max_vel) then + max_vel = tempv + endif + enddo + enddo + + u_last(:,:) = u(:,:) + v_last(:,:) = v(:,:) + + call max_across_PEs(max_vel) + call max_across_PEs(err_max) + err_init = max_vel + + endif + + if (is_root_pe()) print *,"nonlinear residual: ",err_max/err_init + + if (err_max <= CS%nonlinear_tolerance * err_init) then + if (is_root_pe()) & + print *,"exiting nonlinear solve after ",iter," iterations" + exit + endif + + enddo + + deallocate(Phi) + deallocate(Phisub) + +end subroutine ice_shelf_solve_outer + +subroutine ice_shelf_solve_inner(CS, ISS, G, u, v, taudx, taudy, H_node, float_cond, & + hmask, conv_flag, iters, time, Phi, Phisub) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u !< The zonal ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v !< The meridional ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: taudx !< The x-direction driving stress, in ??? + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: taudy !< The y-direction driving stress, in ??? + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: 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 + integer, intent(out) :: conv_flag !< A flag indicating whether (1) or not (0) the + !! iterations have converged to the specified tolerence + integer, intent(out) :: iters !< The number of iterations used in the solver. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(SZDI_(G),SZDJ_(G),8,4), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations +! one linear solve (nonlinear iteration) of the solution for velocity + +! in this subroutine: +! boundary contributions are added to taud to get the RHS +! diagonal of matrix is found (for Jacobi precondition) +! CG iteration is carried out for max. iterations or until convergence + +! assumed - u, v, taud, visc, beta_eff are valid on the halo + + real, dimension(SZDIB_(G),SZDJB_(G)) :: & + Ru, Rv, Zu, Zv, DIAGu, DIAGv, RHSu, RHSv, & + ubd, vbd, Au, Av, Du, Dv, & + Zu_old, Zv_old, Ru_old, Rv_old, & + sum_vec, sum_vec_2 + integer :: iter, i, j, isd, ied, jsd, jed, & + isc, iec, jsc, jec, is, js, ie, je, isumstart, jsumstart, & + isdq, iedq, jsdq, jedq, iscq, iecq, jscq, jecq, nx_halo, ny_halo + real :: tol, beta_k, alpha_k, area, dot_p1, dot_p2, resid0, cg_halo, dot_p1a, dot_p2a + character(2) :: gridsize + + real, dimension(8,4) :: Phi_temp + real, dimension(2,2) :: X,Y + + isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB + iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB + ny_halo = G%domain%njhalo ; nx_halo = G%domain%nihalo + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 + dot_p1 = 0 ; dot_p2 = 0 + + isumstart = G%isc + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) isumstart = G%iscB + + jsumstart = G%jsc + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) jsumstart = G%jscB + + call apply_boundary_values(CS, ISS, G, time, Phisub, H_node, CS%ice_visc, & + CS%taub_beta_eff, float_cond, & + CS%density_ice/CS%density_ocean_avg, ubd, vbd) + + RHSu(:,:) = taudx(:,:) - ubd(:,:) + RHSv(:,:) = taudy(:,:) - vbd(:,:) + + + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) + + call matrix_diagonal(CS, G, float_cond, H_node, CS%ice_visc, & + CS%taub_beta_eff, hmask, & + CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) +! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 + + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) + + call CG_action(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & + G%areaT, G, isc-1, iec+1, jsc-1, jec+1, CS%density_ice/CS%density_ocean_avg) + + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + + Ru(:,:) = RHSu(:,:) - Au(:,:) ; Rv(:,:) = RHSv(:,:) - Av(:,:) + + if (.not. CS%use_reproducing_sums) then + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) dot_p1 = dot_p1 + Ru(i,j)**2 + if (CS%vmask(i,j) == 1) dot_p1 = dot_p1 + Rv(i,j)**2 + enddo + enddo + + call sum_across_PEs(dot_p1) + + else + + sum_vec(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + + endif + + resid0 = sqrt (dot_p1) + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 1) Zu(i,j) = Ru(i,j) / DIAGu(i,j) + if (CS%vmask(i,j) == 1) Zv(i,j) = Rv(i,j) / DIAGv(i,j) + enddo + enddo + + Du(:,:) = Zu(:,:) ; Dv(:,:) = Zv(:,:) + + cg_halo = 3 + conv_flag = 0 + + !!!!!!!!!!!!!!!!!! + !! !! + !! MAIN CG LOOP !! + !! !! + !!!!!!!!!!!!!!!!!! + + + + ! initially, c-grid data is valid up to 3 halo nodes out + + do iter = 1,CS%cg_max_iterations + + ! assume asymmetry + ! thus we can never assume that any arrays are legit more than 3 vertices past + ! the computational domain - this is their state in the initial iteration + + + is = isc - cg_halo ; ie = iecq + cg_halo + js = jscq - cg_halo ; je = jecq + cg_halo + + Au(:,:) = 0 ; Av(:,:) = 0 + + call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + H_node, CS%ice_visc, float_cond, G%bathyT, CS%taub_beta_eff, & + G%areaT, G, is, ie, js, je, CS%density_ice/CS%density_ocean_avg) + + ! Au, Av valid region moves in by 1 + + if ( .not. CS%use_reproducing_sums) then + + + ! alpha_k = (Z \dot R) / (D \dot AD} + dot_p1 = 0 ; dot_p2 = 0 + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + Du(i,j)*Au(i,j) + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + Dv(i,j)*Av(i,j) + endif + enddo + enddo + call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) + else + + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + + do j=jscq,jecq + do i=iscq,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Zv(i,j) * Rv(i,j) + + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + Dv(i,j) * Av(i,j) + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + + dot_p2 = reproducing_sum( sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + endif + + alpha_k = dot_p1/dot_p2 + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) + if (CS%vmask(i,j) == 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) + enddo + enddo + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) then + Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) + endif + if (CS%vmask(i,j) == 1) then + Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) + endif + enddo + enddo + +! Ru(:,:) = Ru(:,:) - alpha_k * Au(:,:) +! Rv(:,:) = Rv(:,:) - alpha_k * Av(:,:) + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) + if (CS%vmask(i,j) == 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) + enddo + enddo + + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 1) then + Zu(i,j) = Ru(i,j) / DIAGu(i,j) + endif + if (CS%vmask(i,j) == 1) then + Zv(i,j) = Rv(i,j) / DIAGv(i,j) + endif + enddo + enddo + + ! R,u,v,Z valid region moves in by 1 + + if (.not. CS%use_reproducing_sums) then + + ! beta_k = (Z \dot R) / (Zold \dot Rold} + dot_p1 = 0 ; dot_p2 = 0 + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) + dot_p2 = dot_p2 + Zu_old(i,j)*Ru_old(i,j) + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) + dot_p2 = dot_p2 + Zv_old(i,j)*Rv_old(i,j) + endif + enddo + enddo + call sum_across_PEs(dot_p1) ; call sum_across_PEs(dot_p2) + + + else + + sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + & + Zv(i,j) * Rv(i,j) + + if (CS%umask(i,j) == 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) + if (CS%vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & + Zv_old(i,j) * Rv_old(i,j) + enddo + enddo + + + dot_p1 = reproducing_sum(sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) + + dot_p2 = reproducing_sum(sum_vec_2, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), Jecq+(1-G%JsdB) ) + + endif + + beta_k = dot_p1/dot_p2 + + +! Du(:,:) = Zu(:,:) + beta_k * Du(:,:) +! Dv(:,:) = Zv(:,:) + beta_k * Dv(:,:) + + do j=jsd,jed + do i=isd,ied + if (CS%umask(i,j) == 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) + if (CS%vmask(i,j) == 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) + enddo + enddo + + ! D valid region moves in by 1 + + dot_p1 = 0 + + if (.not. CS%use_reproducing_sums) then + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) then + dot_p1 = dot_p1 + Ru(i,j)**2 + endif + if (CS%vmask(i,j) == 1) then + dot_p1 = dot_p1 + Rv(i,j)**2 + endif + enddo + enddo + call sum_across_PEs(dot_p1) + + else + + sum_vec(:,:) = 0.0 + + do j=jsumstart,jecq + do i=isumstart,iecq + if (CS%umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 + if (CS%vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + enddo + enddo + + dot_p1 = reproducing_sum( sum_vec, isumstart+(1-G%IsdB), Iecq+(1-G%IsdB), & + jsumstart+(1-G%JsdB), jecq+(1-G%JsdB) ) + endif + + dot_p1 = sqrt (dot_p1) + + if (dot_p1 <= CS%cg_tolerance * resid0) then + iters = iter + conv_flag = 1 + exit + endif + + cg_halo = cg_halo - 1 + + if (cg_halo == 0) then + ! pass vectors + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u, v, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) + cg_halo = 3 + endif + + enddo ! end of CG loop + + do j=jsdq,jedq + do i=isdq,iedq + if (CS%umask(i,j) == 3) then + u(i,j) = CS%u_bdry_val(i,j) + elseif (CS%umask(i,j) == 0) then + u(i,j) = 0 + endif + + if (CS%vmask(i,j) == 3) then + v(i,j) = CS%v_bdry_val(i,j) + elseif (CS%vmask(i,j) == 0) then + v(i,j) = 0 + endif + enddo + enddo + + call pass_vector(u,v, G%domain, TO_ALL, BGRID_NE) + + if (conv_flag == 0) then + iters = CS%cg_max_iterations + endif + +end subroutine ice_shelf_solve_inner + +subroutine ice_shelf_advect_thickness_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + 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) :: h0 !< The initial ice shelf thicknesses in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries, in m3 + + ! 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 + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: u_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + 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 + + do j=jsd+1,jed-1 + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + + stencil(:) = -1 +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) + do i=is,ie + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + + if (i+i_off == G%domain%nihalo+1) then + at_west_bdry=.true. + else + at_west_bdry=.false. + endif + + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then + at_east_bdry=.true. + else + at_east_bdry=.false. + endif + + if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + + h_after_uflux(i,j) = h0(i,j) + + stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 + + flux_diff_cell = 0 + + ! 1ST DO LEFT FACE + + if (CS%u_face_mask(i-1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) / dxdyh + + else + + ! get u-velocity at center of left face + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + stencil (-1) = CS%thickness_bdry_val(i-1,j) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(i-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i-2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) + + endif + + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + + else + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) + endif + endif + endif + endif + + ! NEXT DO RIGHT FACE + + ! get u-velocity at center of right face + + if (CS%u_face_mask(i+1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) / dxdyh + + else + + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh + + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid + + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) + + endif + + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + + endif + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i-1,j) + elseif (CS%u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j) + endif + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) + endif + + if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + + hmask(i,j) = 2 + elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + + hmask(i,j) = 2 + + endif + + endif + + endif + + enddo ! i loop + + endif + + enddo ! j loop + +end subroutine ice_shelf_advect_thickness_x + +subroutine ice_shelf_advect_thickness_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + 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_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_vflux !< The ice shelf thicknesses after + !! the meridional mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries, in m3 + + ! 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 + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: v_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + 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 + + do i=isd+2,ied-2 + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries + + stencil(:) = -1 + + do j=js,je + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + if (j+j_off == G%domain%njhalo+1) then + at_south_bdry=.true. + else + at_south_bdry=.false. + endif + + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then + at_north_bdry=.true. + else + at_north_bdry=.false. + endif + + if (hmask(i,j) == 1) then + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + h_after_vflux(i,j) = h_after_uflux(i,j) + + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 + flux_diff_cell = 0 + + ! 1ST DO south FACE + + if (CS%v_face_mask(i,j-1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) / dxdyh + + else + + ! get u-velocity at center of left face + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid + + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(j-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j-2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) + endif + + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + else + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + endif + + ! NEXT DO north FACE + + if (CS%v_face_mask(i,j+1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) / dxdyh + + else + + ! get u-velocity at center of right face + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) + endif + + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) + endif + endif + + endif + + endif + + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then + v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j-1) + elseif (CS%v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1) + endif + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then + v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1) + endif + + if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + hmask(i,j) = 2 + elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + hmask(i,j) = 2 + endif + + endif + endif + enddo ! j loop + endif + enddo ! i loop + +end subroutine ice_shelf_advect_thickness_y + +subroutine shelf_advance_front(CS, ISS, G, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The ice volume flux into the cell + !! through the 4 cell boundaries, in m3 + + ! in this subroutine we go through the computational cells only and, if they are empty or partial cells, + ! we find the reference thickness and update the shelf mass and partial area fraction and the hmask if necessary + + ! if any cells go from partial to complete, we then must set the thickness, update hmask accordingly, + ! and divide the overflow across the adjacent EMPTY (not partly-covered) cells. + ! (it is highly unlikely there will not be any; in which case this will need to be rethought.) + + ! most likely there will only be one "overflow". if not, though, a pass_var of all relevant variables + ! is done; there will therefore be a loop which, in practice, will hopefully not have to go through + ! many iterations + + ! when 3d advected scalars are introduced, they will be impacted by what is done here + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count + integer :: i_off, j_off + integer :: iter_flag + + real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux + integer, dimension(4) :: mapi, mapj, new_partial +! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter_replace + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + i_off = G%idg_offset ; j_off = G%jdg_offset + rho = CS%density_ice + iter_count = 0 ; iter_flag = 1 + + + mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 + mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 + + do while (iter_flag == 1) + + iter_flag = 0 + + if (iter_count > 0) then + flux_enter(:,:,:) = flux_enter_replace(:,:,:) + endif + flux_enter_replace(:,:,:) = 0.0 + + iter_count = iter_count + 1 + + ! if iter_count >= 3 then some halo updates need to be done... + + do j=jsc-1,jec+1 + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + do i=isc-1,iec+1 + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + ! first get reference thickness by averaging over cells that are fluxing into this cell + n_flux = 0 + h_reference = 0.0 + tot_flux = 0.0 + + do k=1,2 + if (flux_enter(i,j,k) > 0) then + n_flux = n_flux + 1 + h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) + tot_flux = tot_flux + flux_enter(i,j,k) + flux_enter(i,j,k) = 0.0 + endif + enddo + + do k=1,2 + if (flux_enter(i,j,k+2) > 0) then + n_flux = n_flux + 1 + h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) + tot_flux = tot_flux + flux_enter(i,j,k+2) + flux_enter(i,j,k+2) = 0.0 + endif + enddo + + if (n_flux > 0) then + dxdyh = G%areaT(i,j) + h_reference = h_reference / real(n_flux) + partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux + + if ((partial_vol / dxdyh) == h_reference) then ! cell is exactly covered, no overflow + ISS%hmask(i,j) = 1 + ISS%h_shelf(i,j) = h_reference + ISS%area_shelf_h(i,j) = dxdyh + elseif ((partial_vol / dxdyh) < h_reference) then + ISS%hmask(i,j) = 2 + ! ISS%mass_shelf(i,j) = partial_vol * rho + ISS%area_shelf_h(i,j) = partial_vol / h_reference + ISS%h_shelf(i,j) = h_reference + else + + ISS%hmask(i,j) = 1 + ISS%area_shelf_h(i,j) = dxdyh + !h_temp(i,j) = h_reference + partial_vol = partial_vol - h_reference * dxdyh + + iter_flag = 1 + + n_flux = 0 ; new_partial(:) = 0 + + do k=1,2 + if (CS%u_face_mask(i-2+k,j) == 2) then + n_flux = n_flux + 1 + elseif (ISS%hmask(i+2*k-3,j) == 0) then + n_flux = n_flux + 1 + new_partial(k) = 1 + endif + enddo + do k=1,2 + if (CS%v_face_mask(i,j-2+k) == 2) then + n_flux = n_flux + 1 + elseif (ISS%hmask(i,j+2*k-3) == 0) then + n_flux = n_flux + 1 + new_partial(k+2) = 1 + endif + enddo + + if (n_flux == 0) then ! there is nowhere to put the extra ice! + ISS%h_shelf(i,j) = h_reference + partial_vol / dxdyh + else + ISS%h_shelf(i,j) = h_reference + + do k=1,2 + if (new_partial(k) == 1) & + flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) + enddo + do k=1,2 ! ### Combine these two loops? + if (new_partial(k+2) == 1) & + flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) + enddo + endif + + endif ! Parital_vol test. + endif ! n_flux gt 0 test. + + endif + enddo ! j-loop + endif + enddo + + ! call max_across_PEs(iter_flag) + + enddo ! End of do while(iter_flag) loop + + call max_across_PEs(iter_count) + + if (is_root_pe() .and. (iter_count > 1)) print *, iter_count, "MAX ITERATIONS,ADVANCE FRONT" + +end subroutine shelf_advance_front + +!> Apply a very simple calving law using a minimum thickness rule +subroutine ice_shelf_min_thickness_calve(G, h_shelf, area_shelf_h, hmask, thickness_calve) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + 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, intent(in) :: thickness_calve !< The thickness at which to trigger calving, in m. + + integer :: i,j + + do j=G%jsd,G%jed + do i=G%isd,G%ied +! if ((h_shelf(i,j) < CS%thickness_calve) .and. (hmask(i,j) == 1) .and. & +! (CS%float_frac(i,j) == 0.0)) then + if ((h_shelf(i,j) < thickness_calve) .and. (area_shelf_h(i,j) > 0.)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo + enddo + +end subroutine ice_shelf_min_thickness_calve + +subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + 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) :: calve_mask !< A mask that indicates where the ice shelf + !! can exist, and where it will calve. + + integer :: i,j + + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if ((calve_mask(i,j) == 0.0) .and. (hmask(i,j) /= 0.0)) then + h_shelf(i,j) = 0.0 + area_shelf_h(i,j) = 0.0 + hmask(i,j) = 0.0 + endif + enddo ; enddo + +end subroutine calve_to_mask + +subroutine calc_shelf_driving_stress(CS, ISS, G, TAUD_X, TAUD_Y, OD) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: OD !< ocean floor depth at tracer points, in m + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: TAUD_X !< X-direction driving stress at q-points + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: TAUD_Y !< Y-direction driving stress at q-points + +! driving stress! + +! ! TAUD_X and TAUD_Y will hold driving stress in the x- and y- directions when done. +! they will sit on the BGrid, and so their size depends on whether the grid is symmetric +! +! Since this is a finite element solve, they will actually have the form \int \phi_i rho g h \nabla s +! +! OD -this is important and we do not yet know where (in MOM) it will come from. It represents +! "average" ocean depth -- and is needed to find surface elevation +! (it is assumed that base_ice = bed + OD) + + real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation + BASE ! basal elevation of shelf/stream + + + real :: rho, rhow, sx, sy, neumann_val, dxh, dyh, dxdyh, grav + + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, 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 + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo + is = iscq - 1; js = jscq - 1 + i_off = G%idg_offset ; j_off = G%jdg_offset + + rho = CS%density_ice + rhow = CS%density_ocean_avg + grav = CS%g_Earth + + ! prelim - go through and calculate S + + ! or is this faster? + BASE(:,:) = -G%bathyT(:,:) + OD(:,:) + S(:,:) = BASE(:,:) + ISS%h_shelf(:,:) + + do j=jsc-1,jec+1 + do i=isc-1,iec+1 + cnt = 0 + sx = 0 + sy = 0 + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell + + ! calculate sx + if ((i+i_off) == gisc) then ! at left computational bdry + if (ISS%hmask(i+1,j) == 1) then + sx = (S(i+1,j)-S(i,j))/dxh + else + sx = 0 + endif + elseif ((i+i_off) == giec) then ! at right computational bdry + if (ISS%hmask(i-1,j) == 1) then + sx = (S(i,j)-S(i-1,j))/dxh + else + sx=0 + endif + else ! interior + if (ISS%hmask(i+1,j) == 1) then + cnt = cnt+1 + sx = S(i+1,j) + else + sx = S(i,j) + endif + if (ISS%hmask(i-1,j) == 1) then + cnt = cnt+1 + sx = sx - S(i-1,j) + else + sx = sx - S(i,j) + endif + if (cnt == 0) then + sx=0 + else + sx = sx / (cnt * dxh) + endif + endif + + cnt = 0 + + ! calculate sy, similarly + if ((j+j_off) == gjsc) then ! at south computational bdry + if (ISS%hmask(i,j+1) == 1) then + sy = (S(i,j+1)-S(i,j))/dyh + else + sy = 0 + endif + elseif ((j+j_off) == gjec) then ! at nprth computational bdry + if (ISS%hmask(i,j-1) == 1) then + sy = (S(i,j)-S(i,j-1))/dyh + else + sy = 0 + endif + else ! interior + if (ISS%hmask(i,j+1) == 1) then + cnt = cnt+1 + sy = S(i,j+1) + else + sy = S(i,j) + endif + if (ISS%hmask(i,j-1) == 1) then + cnt = cnt+1 + sy = sy - S(i,j-1) + else + sy = sy - S(i,j) + endif + if (cnt == 0) then + sy=0 + else + sy = sy / (cnt * dyh) + endif + endif + + ! SW vertex + taud_x(I-1,J-1) = taud_x(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I-1,J-1) = taud_y(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! SE vertex + taud_x(I,J-1) = taud_x(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I,J-1) = taud_y(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! NW vertex + taud_x(I-1,J) = taud_x(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I-1,J) = taud_y(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + ! NE vertex + taud_x(I,J) = taud_x(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * dxdyh + taud_y(I,J) = taud_y(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * dxdyh + + if (CS%float_frac(i,j) == 1) then + neumann_val = .5 * grav * (rho * ISS%h_shelf(i,j) ** 2 - rhow * G%bathyT(i,j) ** 2) + else + neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j) ** 2 + endif + + + if ((CS%u_face_mask(i-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then + ! left face of the cell is at a stress boundary + ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated + ! pressure on either side of the face + ! on the ice side, it is rho g h^2 / 2 + ! on the ocean side, it is rhow g (delta OD)^2 / 2 + ! OD can be zero under the ice; but it is ASSUMED on the ice-free side of the face, topography elevation + ! is not above the base of the ice in the current cell + + ! note negative sign due to direction of normal vector + taud_x(i-1,j-1) = taud_x(i-1,j-1) - .5 * dyh * neumann_val + taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val + endif + + if ((CS%u_face_mask(i,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then + ! right face of the cell is at a stress boundary + taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val + taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val + endif + + if ((CS%v_face_mask(i,j-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then + ! south face of the cell is at a stress boundary + taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val + taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val + endif + + if ((CS%v_face_mask(i,j) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then + ! north face of the cell is at a stress boundary + taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val ! note negative sign due to direction of normal vector + taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val + endif + + endif + enddo + enddo + +end subroutine calc_shelf_driving_stress + +subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) + type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + 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, intent(in) :: input_flux !< The integrated inward ice thickness flux in m3 s-1. + real, intent(in) :: input_thick !< The ice thickness at boundaries, in m. + logical, optional, intent(in) :: new_sim !< If present and false, this run is being restarted + +! this will be a per-setup function. the boundary values of thickness and velocity +! (and possibly other variables) will be updated in this function + +! FOR RESTARTING PURPOSES: if grid is not symmetric and the model is restarted, we will +! need to update those velocity points not *technically* in any +! computational domain -- if this function gets moves to another module, +! DO NOT TAKE THE RESTARTING BIT WITH IT + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq + integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + integer :: i_off, j_off + real :: A, n, ux, uy, vx, vy, eps_min, domain_width + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec +! iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed +! iegq = G%iegq ; jegq = G%jegq + i_off = G%idg_offset ; j_off = G%jdg_offset + + domain_width = G%len_lat + + ! this loop results in some values being set twice but... eh. + + do j=jsd,jed + do i=isd,ied + + if (hmask(i,j) == 3) then + CS%thickness_bdry_val(i,j) = input_thick + endif + + if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then + if ((i <= iec).and.(i >= isc)) then + if (CS%u_face_mask(i-1,j) == 3) then + CS%u_bdry_val(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 1.5 * input_flux / input_thick + CS%u_bdry_val(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*G%len_lat)*2./G%len_lat)**2) * & + 1.5 * input_flux / input_thick + endif + endif + endif + + if (.not.(new_sim)) then + if (.not. G%symmetric) then + if (((i+i_off) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i-1,j) = CS%u_bdry_val(i-1,j) + endif + if (((j+j_off) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_bdry_val(i-1,j-1) + CS%u_shelf(i,j-1) = CS%u_bdry_val(i,j-1) + endif + endif + endif + enddo + enddo + +end subroutine init_boundary_values + + +subroutine CG_action(uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & + nu, float_cond, bathyT, beta, dxdyh, G, is, ie, js, je, dens_ratio) + + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: uret !< The retarding stresses working at u-points. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: vret !< The retarding stresses working at v-points. + real, dimension(SZDI_(G),SZDJ_(G),8,4), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: u !< The zonal ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: v !< The meridional ice shelf velocity at vertices, in m/year + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points, in m. + 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(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: 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) :: bathyT !< The depth of ocean bathymetry at tracer points, in m. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent. + ! and/or whether flow is "hybridized" + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: dxdyh !< The tracer cell area, in m2 + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + integer, intent(in) :: is !< The starting i-index to work on + integer, intent(in) :: ie !< The ending i-index to work on + integer, intent(in) :: js !< The starting j-index to work on + integer, intent(in) :: je !< The ending j-index to work on + +! the linear action of the matrix on (u,v) with bilinear finite elements +! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, +! but this may change pursuant to conversations with others +! +! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine +! in order to make less frequent halo updates + +! the linear action of the matrix on (u,v) with bilinear finite elements +! Phi has the form +! Phi(i,j,k,q) - applies to cell i,j + + ! 3 - 4 + ! | | + ! 1 - 2 + +! Phi(i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q +! Phi(i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q +! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear + + real :: ux, vx, uy, vy, uq, vq, area, basel + integer :: iq, jq, iphi, jphi, i, j, ilq, jlq + real, dimension(2) :: xquad + real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr,Ucontr + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + + do j=js,je + do i=is,ie ; if (hmask(i,j) == 1) then +! dxh = G%dxh(i,j) +! dyh = G%dyh(i,j) +! +! X(:,:) = G%geoLonBu(i-1:i,j-1:j) +! Y(:,:) = G%geoLatBu(i-1:i,j-1:j) +! +! call bilinear_shape_functions (X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + area = dxdyh(i,j) + + Ucontr=0 + do iq=1,2 ; do jq=1,2 + + + if (iq == 2) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == 2) then + jlq = 2 + else + jlq = 1 + endif + + uq = u(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + u(i,j-1) * xquad(iq) * xquad(3-jq) + & + u(i-1,j) * xquad(3-iq) * xquad(jq) + & + u(i,j) * xquad(iq) * xquad(jq) + + vq = v(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + v(i,j-1) * xquad(iq) * xquad(3-jq) + & + v(i-1,j) * xquad(3-iq) * xquad(jq) + & + v(i,j) * xquad(iq) * xquad(jq) + + ux = u(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + u(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + u(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + u(i,j) * Phi(i,j,7,2*(jq-1)+iq) + + vx = v(i-1,j-1) * Phi(i,j,1,2*(jq-1)+iq) + & + v(i,j-1) * Phi(i,j,3,2*(jq-1)+iq) + & + v(i-1,j) * Phi(i,j,5,2*(jq-1)+iq) + & + v(i,j) * Phi(i,j,7,2*(jq-1)+iq) + + uy = u(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + u(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + u(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + u(i,j) * Phi(i,j,8,2*(jq-1)+iq) + + vy = v(i-1,j-1) * Phi(i,j,2,2*(jq-1)+iq) + & + v(i,j-1) * Phi(i,j,4,2*(jq-1)+iq) + & + v(i-1,j) * Phi(i,j,6,2*(jq-1)+iq) + & + v(i,j) * Phi(i,j,8,2*(jq-1)+iq) + + do iphi=1,2 ; do jphi=1,2 + if (umask(i-2+iphi,j-2+jphi) == 1) then + + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + .25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + endif + if (vmask(i-2+iphi,j-2+jphi) == 1) then + + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + .25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + endif + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (float_cond(i,j) == 0) then + + if (umask(i-2+iphi,j-2+jphi) == 1) then + + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) + + endif + + if (vmask(i-2+iphi,j-2+jphi) == 1) then + + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) + + endif + + endif + Ucontr(iphi,jphi) = Ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j) + enddo ; enddo + enddo ; enddo + + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = bathyT(i,j) + Ucell(:,:) = u(i-1:i,j-1:j) ; Vcell(:,:) = v(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal & + (Phisub, Hcell, Ucell, Vcell, area, basel, dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi=1,2 + if (umask(i-2+iphi,j-2+jphi) == 1) then + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) + endif + if (vmask(i-2+iphi,j-2+jphi) == 1) then + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + + endif + enddo ; enddo + +end subroutine CG_action + +subroutine CG_action_subgrid_basal(Phisub, H, U, V, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(2,2), intent(in) :: H !< The ice shelf thickness at nodal (corner) points, in m. + real, dimension(2,2), intent(in) :: U !< The zonal ice shelf velocity at vertices, in m/year + real, dimension(2,2), intent(in) :: V !< The meridional ice shelf velocity at vertices, in m/year + real, intent(in) :: DXDYH !< The tracer cell area, in m2 + real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points, in m. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to + !! the u-direction basal stress. + real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to + !! the v-direction basal stress. + + integer :: nsub, i, j, k, l, qx, qy, m, n + real :: subarea, hloc, uq, vq + + nsub = size(Phisub,1) + subarea = DXDYH / (nsub**2) + + do m=1,2 + do n=1,2 + do j=1,nsub + do i=1,nsub + do qx=1,2 + do qy = 1,2 + + hloc = Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,1,2,qx,qy)*H(1,2) + & + Phisub(i,j,2,1,qx,qy)*H(2,1) + Phisub(i,j,2,2,qx,qy)*H(2,2) + + if (dens_ratio * hloc - bathyT > 0) then + !if (.true.) then + uq = 0 ; vq = 0 + do k=1,2 + do l=1,2 + !Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * U(k,l) + !Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * Phisub(i,j,k,l,qx,qy) * V(k,l) + uq = uq + Phisub(i,j,k,l,qx,qy) * U(k,l) ; vq = vq + Phisub(i,j,k,l,qx,qy) * V(k,l) + enddo + enddo + + Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * uq + Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * vq + + endif + + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine CG_action_subgrid_basal + +!> returns the diagonal entries of the matrix for a Jacobi preconditioning +subroutine matrix_diagonal(CS, G, float_cond, H_node, nu, beta, hmask, dens_ratio, & + Phisub, u_diagonal, v_diagonal) + + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal + !! (corner) points, in m. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent + 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, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_diagonal !< The diagonal elements of the u-velocity + !! matrix from the left-hand side of the solver. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_diagonal !< The diagonal elements of the v-velocity + !! matrix from the left-hand side of the solver. + + +! returns the diagonal entries of the matrix for a Jacobi preconditioning + + integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq + real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, area, uq, vq, basel + real, dimension(8,4) :: Phi + real, dimension(4) :: X, Y + real, dimension(2) :: xquad + real, dimension(2,2) :: Hcell,Usubcontr,Vsubcontr + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 + X(3:4) = G%geoLonBu(i-1:i,j) *1000 + Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000 + Y(3:4) = G%geoLatBu(i-1:i,j)*1000 + + call bilinear_shape_functions(X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do iq=1,2 ; do jq=1,2 + + do iphi=1,2 ; do jphi=1,2 + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + + ux = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + uy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + vx = 0. + vy = 0. + + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + uq = xquad(ilq) * xquad(jlq) + + if (float_cond(i,j) == 0) then + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) + endif + + endif + + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + + vx = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + vy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + ux = 0. + uy = 0. + + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + vq = xquad(ilq) * xquad(jlq) + + if (float_cond(i,j) == 0) then + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) + endif + + endif + enddo ; enddo + enddo ; enddo + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_diagonal_subgrid_basal & + (Phisub, Hcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi=1,2 + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + endif ; enddo ; enddo + +end subroutine matrix_diagonal + +subroutine CG_diagonal_subgrid_basal (Phisub, H_node, DXDYH, bathyT, dens_ratio, Ucontr, Vcontr) + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(2,2), intent(in) :: H_node !< The ice shelf thickness at nodal (corner) + !! points, in m + real, intent(in) :: DXDYH !< The tracer cell area, in m2 + real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points, in m + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(2,2), intent(inout) :: Ucontr !< A field related to the subgridscale contributions to + !! the u-direction diagonal elements from basal stress. + real, dimension(2,2), intent(inout) :: Vcontr !< A field related to the subgridscale contributions to + !! the v-direction diagonal elements from basal stress. + + ! bathyT = cellwise-constant bed elevation + + integer :: nsub, i, j, k, l, qx, qy, m, n + real :: subarea, hloc + + nsub = size(Phisub,1) + subarea = DXDYH / (nsub**2) + + do m=1,2 ; do n=1,2 ; do j=1,nsub ; do i=1,nsub ; do qx=1,2 ; do qy = 1,2 + + hloc = Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,1,2,qx,qy)*H_node(1,2) + & + Phisub(i,j,2,1,qx,qy)*H_node(2,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2) + + if (dens_ratio * hloc - bathyT > 0) then + Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 + Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 + endif + + enddo ; enddo ; enddo ; enddo ; enddo ; enddo + +end subroutine CG_diagonal_subgrid_basal + + +subroutine apply_boundary_values(CS, ISS, G, time, Phisub, H_node, nu, beta, float_cond, & + dens_ratio, u_bdry_contr, v_bdry_contr) + + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + type(time_type), intent(in) :: Time !< The current model time + real, dimension(:,:,:,:,:,:), & + intent(in) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: H_node !< The ice shelf thickness at nodal + !! (corner) points, in m. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: nu !< A field related to the ice viscosity from Glen's + !! flow law. The exact form and units depend on the + !! basal law exponent. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(in) :: beta !< A field related to the nonlinear part of the + !! "linearized" basal stress. The exact form and + !! units depend on the basal law exponent + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: float_cond !< An array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not. + real, intent(in) :: dens_ratio !< The density of ice divided by the density + !! of seawater, nondimensional + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: u_bdry_contr !< Contributions to the zonal ice + !! velocities due to the open boundaries + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: v_bdry_contr !< Contributions to the zonal ice + !! velocities due to the open boundaries + +! this will be a per-setup function. the boundary values of thickness and velocity +! (and possibly other variables) will be updated in this function + + real, dimension(8,4) :: Phi + real, dimension(4) :: X, Y + real, dimension(2) :: xquad + integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq + real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh, uq, vq, area, basel + real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr + + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then + + ! process this cell if any corners have umask set to non-dirichlet bdry. + ! NOTE: vmask not considered, probably should be + + if ((CS%umask(i-1,j-1) == 3) .OR. (CS%umask(i,j-1) == 3) .OR. & + (CS%umask(i-1,j) == 3) .OR. (CS%umask(i,j) == 3)) then + + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 + X(3:4) = G%geoLonBu(i-1:i,j)*1000 + Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000 + Y(3:4) = G%geoLatBu(i-1:i,j)*1000 + + call bilinear_shape_functions(X, Y, Phi, area) + + ! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j + ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j + + + + do iq=1,2 ; do jq=1,2 + + uq = CS%u_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + CS%u_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%u_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & + CS%u_bdry_val(i,j) * xquad(iq) * xquad(jq) + + vq = CS%v_bdry_val(i-1,j-1) * xquad(3-iq) * xquad(3-jq) + & + CS%v_bdry_val(i,j-1) * xquad(iq) * xquad(3-jq) + & + CS%v_bdry_val(i-1,j) * xquad(3-iq) * xquad(jq) + & + CS%v_bdry_val(i,j) * xquad(iq) * xquad(jq) + + ux = CS%u_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%u_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) + + vx = CS%v_bdry_val(i-1,j-1) * Phi(1,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j-1) * Phi(3,2*(jq-1)+iq) + & + CS%v_bdry_val(i-1,j) * Phi(5,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j) * Phi(7,2*(jq-1)+iq) + + uy = CS%u_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%u_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & + CS%u_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) + + vy = CS%v_bdry_val(i-1,j-1) * Phi(2,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j-1) * Phi(4,2*(jq-1)+iq) + & + CS%v_bdry_val(i-1,j) * Phi(6,2*(jq-1)+iq) + & + CS%v_bdry_val(i,j) * Phi(8,2*(jq-1)+iq) + + do iphi=1,2 ; do jphi=1,2 + + if (iq == iphi) then + ilq = 2 + else + ilq = 1 + endif + + if (jq == jphi) then + jlq = 2 + else + jlq = 1 + endif + + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + + + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) + + if (float_cond(i,j) == 0) then + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) + endif + + endif + + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + + + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + if (float_cond(i,j) == 0) then + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) + endif + + endif + enddo ; enddo + enddo ; enddo + + if (float_cond(i,j) == 1) then + Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) + Ucell(:,:) = CS%u_bdry_val(i-1:i,j-1:j) ; Vcell(:,:) = CS%v_bdry_val(i-1:i,j-1:j) + Hcell(:,:) = H_node(i-1:i,j-1:j) + call CG_action_subgrid_basal & + (Phisub, Hcell, Ucell, Vcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) + do iphi=1,2 ; do jphi = 1,2 + if (CS%umask(i-2+iphi,j-2+jphi) == 1) then + u_bdry_contr(i-2+iphi,j-2+jphi) = u_bdry_contr(i-2+iphi,j-2+jphi) + & + Usubcontr(iphi,jphi) * beta(i,j) + endif + if (CS%vmask(i-2+iphi,j-2+jphi) == 1) then + v_bdry_contr(i-2+iphi,j-2+jphi) = v_bdry_contr(i-2+iphi,j-2+jphi) + & + Vsubcontr(iphi,jphi) * beta(i,j) + endif + enddo ; enddo + endif + endif + endif ; enddo ; enddo + +end subroutine apply_boundary_values + +!> Update depth integrated viscosity, based on horizontal strain rates, and also update the +!! nonlinear part of the basal traction. +subroutine calc_shelf_visc(CS, ISS, G, u, v) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: u !< The zonal ice shelf velocity, in m/year. + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(inout) :: v !< The meridional ice shelf velocity, in m/year. + +! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve +! so there is an "upper" and "lower" bilinear viscosity + +! also this subroutine updates the nonlinear part of the basal traction + +! 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 + real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh + + 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 ; ied = G%ied ; jed = G%jed + iegq = G%iegB ; jegq = G%jegB + gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 + giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc + is = iscq - 1; js = jscq - 1 + + A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min + C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction + + do j=jsd+1,jed-1 + do i=isd+1,ied-1 + + dxh = G%dxT(i,j) + dyh = G%dyT(i,j) + dxdyh = G%areaT(i,j) + + if (ISS%hmask(i,j) == 1) then + ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh) + vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh) + uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh) + vy = (v(i,j) - v(i,j-1) + v(i-1,j) - v(i-1,j-1)) / (2*dyh) + + CS%ice_visc(i,j) = .5 * A**(-1/n) * & + (ux**2+vy**2+ux*vy+0.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * & + ISS%h_shelf(i,j) + + umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4 + vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4 + unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) + CS%taub_beta_eff(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + endif + enddo + enddo + +end subroutine calc_shelf_visc + +subroutine update_OD_ffrac(CS, G, ocean_mass, find_avg) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: ocean_mass !< The mass per unit area of the ocean in kg m-2. + logical, intent(in) :: find_avg !< If true, find the average of OD and ffrac, and + !! reset the underlying running sums to 0. + + integer :: isc, iec, jsc, jec, i, j + real :: I_rho_ocean + real :: I_counter + + I_rho_ocean = 1.0/CS%density_ocean_avg + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + do j=jsc,jec ; do i=isc,iec + CS%OD_rt(i,j) = CS%OD_rt(i,j) + ocean_mass(i,j)*I_rho_ocean + if (ocean_mass(i,j)*I_rho_ocean > CS%thresh_float_col_depth) then + CS%float_frac_rt(i,j) = CS%float_frac_rt(i,j) + 1.0 + endif + enddo ; enddo + CS%OD_rt_counter = CS%OD_rt_counter + 1 + + if (find_avg) then + I_counter = 1.0 / real(CS%OD_rt_counter) + do j=jsc,jec ; do i=isc,iec + CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) * I_counter) + CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter + + CS%OD_rt(i,j) = 0.0 ; CS%float_frac_rt(i,j) = 0.0 + enddo ; enddo + + call pass_var(CS%float_frac, G%domain) + call pass_var(CS%OD_av, G%domain) + endif + +end subroutine update_OD_ffrac + +subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< the thickness of the ice shelf in m + + integer :: i, j, iters, isd, ied, jsd, jed + real :: rhoi, rhow, OD + + rhoi = CS%density_ice + rhow = CS%density_ocean_avg + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + do j=jsd,jed + do i=isd,ied + OD = G%bathyT(i,j) - rhoi/rhow * h_shelf(i,j) + if (OD >= 0) then + ! ice thickness does not take up whole ocean column -> floating + CS%OD_av(i,j) = OD + CS%float_frac(i,j) = 0. + else + CS%OD_av(i,j) = 0. + CS%float_frac(i,j) = 1. + endif + enddo + enddo + +end subroutine update_OD_ffrac_uncoupled + +!> This subroutine calculates the gradients of bilinear basis elements that +!! that are centered at the vertices of the cell. values are calculated at +!! points of gaussian quadrature. +subroutine bilinear_shape_functions (X, Y, Phi, area) + real, dimension(4), intent(in) :: X !< The x-positions of the vertices of the quadrilateral. + real, dimension(4), intent(in) :: Y !< The y-positions of the vertices of the quadrilateral. + real, dimension(8,4), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell verticies. + real, intent(out) :: area !< The quadrilateral cell area, in m2. + +! X and Y must be passed in the form + ! 3 - 4 + ! | | + ! 1 - 2 + +! this subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. values are calculated at +! points of gaussian quadrature. (in 1D: .5 * (1 +/- sqrt(1/3)) for [0,1]) +! (ordered in same way as vertices) +! +! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j +! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear +! +! This should be a one-off; once per nonlinear solve? once per lifetime? +! ... will all cells have the same shape and dimension? + + real, dimension(4) :: xquad, yquad + integer :: node, qpoint, xnode, xq, ynode, yq + real :: a,b,c,d,e,f,xexp,yexp + + 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 + + a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) + b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) + c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) + d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) + + do node=1,4 + + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + + if (ynode == 1) then + yexp = 1-yquad(qpoint) + else + yexp = yquad(qpoint) + endif + + if (1 == xnode) then + xexp = 1-xquad(qpoint) + else + xexp = xquad(qpoint) + endif + + Phi (2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp - b * (2 * ynode - 3) * xexp) / (a*d-b*c) + Phi (2*node,qpoint) = ( -c * (2 * xnode - 3) * yexp + a * (2 * ynode - 3) * xexp) / (a*d-b*c) + + enddo + enddo + + area = quad_area(X, Y) + +end subroutine bilinear_shape_functions + + +subroutine bilinear_shape_functions_subgrid(Phisub, nsub) + real, dimension(nsub,nsub,2,2,2,2), & + intent(inout) :: Phisub !< Quadrature structure weights at subgridscale + !! locations for finite element calculations + integer, intent(in) :: nsub !< The nubmer 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 + ! in partial floatation + ! the array Phisub contains the values of \phi_i (where i is a node of the cell) + ! at quad point j + ! i think this general approach may not work for nonrectangular elements... + ! + + ! Phisub(i,j,k,l,q1,q2) + ! i: subgrid index in x-direction + ! j: subgrid index in y-direction + ! k: basis function x-index + ! l: basis function y-index + ! q1: quad point x-index + ! q2: quad point y-index + + ! e.g. k=1,l=1 => node 1 + ! q1=2,q2=1 => quad point 2 + + ! 3 - 4 + ! | | + ! 1 - 2 + + integer :: i, j, k, l, qx, qy, indx, indy + real,dimension(2) :: xquad + real :: x0, y0, x, y, val, fracx + + xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + fracx = 1.0/real(nsub) + + do j=1,nsub + do i=1,nsub + x0 = (i-1) * fracx ; y0 = (j-1) * fracx + do qx=1,2 + do qy=1,2 + x = x0 + fracx*xquad(qx) + y = y0 + fracx*xquad(qy) + do k=1,2 + do l=1,2 + val = 1.0 + if (k == 1) then + val = val * (1.0-x) + else + val = val * x + endif + if (l == 1) then + val = val * (1.0-y) + else + val = val * y + endif + Phisub(i,j,k,l,qx,qy) = val + enddo + enddo + enddo + enddo + enddo + enddo + +end subroutine bilinear_shape_functions_subgrid + + +subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face_mask) + type(ice_shelf_dyn_CS),intent(in) :: CS !< A pointer to the ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + 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(SZDIB_(G),SZDJB_(G)), & + intent(out) :: umask !< A coded mask indicating the nature of the + !! zonal flow at the corner point + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(out) :: vmask !< A coded mask indicating the nature of the + !! meridional flow at the corner point + real, dimension(SZDIB_(G),SZDJ_(G)), & + intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face + real, dimension(SZDI_(G),SZDJB_(G)), & + intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face + ! sets masks for velocity solve + ! ignores the fact that their might be ice-free cells - this only considers the computational boundary + + ! !!!IMPORTANT!!! relies on thickness mask - assumed that this is called after hmask has been updated & halo-updated + + integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq + integer :: giec, gjec, gisc, gjsc, 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 + i_off = G%idg_offset ; j_off = G%jdg_offset + isd = G%isd ; jsd = G%jsd + iegq = G%iegB ; jegq = G%jegB + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + umask(:,:) = 0 ; vmask(:,:) = 0 + u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 + + if (G%symmetric) then + is = isd ; js = jsd + else + is = isd+1 ; js = jsd+1 + endif + + do j=js,G%jed + do i=is,G%ied + + if (hmask(i,j) == 1) then + + umask(i-1:i,j-1:j) = 1. + vmask(i-1:i,j-1:j) = 1. + + do k=0,1 + + select case (int(CS%u_face_mask_bdry(i-1+k,j))) + case (3) + umask(i-1+k,j-1:j)=3. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=3. + case (2) + u_face_mask(i-1+k,j)=2. + case (4) + umask(i-1+k,j-1:j)=0. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=4. + case (0) + umask(i-1+k,j-1:j)=0. + vmask(i-1+k,j-1:j)=0. + u_face_mask(i-1+k,j)=0. + case (1) ! stress free x-boundary + umask(i-1+k,j-1:j)=0. + case default + end select + enddo + + do k=0,1 + + select case (int(CS%v_face_mask_bdry(i,j-1+k))) + case (3) + vmask(i-1:i,j-1+k)=3. + umask(i-1:i,j-1+k)=0. + v_face_mask(i,j-1+k)=3. + case (2) + v_face_mask(i,j-1+k)=2. + case (4) + umask(i-1:i,j-1+k)=0. + vmask(i-1:i,j-1+k)=0. + v_face_mask(i,j-1+k)=4. + case (0) + umask(i-1:i,j-1+k)=0. + vmask(i-1:i,j-1+k)=0. + u_face_mask(i,j-1+k)=0. + case (1) ! stress free y-boundary + vmask(i-1:i,j-1+k)=0. + case default + end select + enddo + + !if (CS%u_face_mask_bdry(i-1,j).geq.0) then !left boundary + ! u_face_mask(i-1,j) = CS%u_face_mask_bdry(i-1,j) + ! umask(i-1,j-1:j) = 3. + ! vmask(i-1,j-1:j) = 0. + !endif + + !if (j_off+j == gjsc+1) then !bot boundary + ! v_face_mask(i,j-1) = 0. + ! umask (i-1:i,j-1) = 0. + ! vmask (i-1:i,j-1) = 0. + !elseif (j_off+j == gjec) then !top boundary + ! v_face_mask(i,j) = 0. + ! umask (i-1:i,j) = 0. + ! vmask (i-1:i,j) = 0. + !endif + + if (i < G%ied) then + if ((hmask(i+1,j) == 0) & + .OR. (hmask(i+1,j) == 2)) then + !right boundary or adjacent to unfilled cell + u_face_mask(i,j) = 2. + endif + endif + + if (i > G%isd) then + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + !adjacent to unfilled cell + u_face_mask(i-1,j) = 2. + endif + endif + + if (j > G%jsd) then + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + !adjacent to unfilled cell + v_face_mask(i,j-1) = 2. + endif + endif + + if (j < G%jed) then + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + !adjacent to unfilled cell + v_face_mask(i,j) = 2. + endif + endif + + + endif + + enddo + enddo + + ! note: if the grid is nonsymmetric, there is a part that will not be transferred with a halo update + ! so this subroutine must update its own symmetric part of the halo + + call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) + call pass_vector(umask, vmask, G%domain, TO_ALL, BGRID_NE) + +end subroutine update_velocity_masks + +!> Interpolate the ice shelf thickness from tracer point to nodal points, +!! subject to a mask. +subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< The ice shelf thickness at tracer points, in m. + 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(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) + !! points, in m. + + integer :: i, j, isc, iec, jsc, jec, num_h, k, l + real :: summ + + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + + H_node(:,:) = 0.0 + + ! H_node is node-centered; average over all cells that share that node + ! if no (active) cells share the node then its value there is irrelevant + + do j=jsc-1,jec + do i=isc-1,iec + summ = 0.0 + num_h = 0 + do k=0,1 + do l=0,1 + if (hmask(i+k,j+l) == 1.0) then + summ = summ + h_shelf(i+k,j+l) + num_h = num_h + 1 + endif + enddo + enddo + if (num_h > 0) then + H_node(i,j) = summ / num_h + endif + enddo + enddo + + call pass_var(H_node, G%domain, position=CORNER) + +end subroutine interpolate_H_to_B + +!> Deallocates all memory associated with the ice shelf dynamics module +subroutine ice_shelf_dyn_end(CS) + type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure + + if (.not.associated(CS)) return + + deallocate(CS%u_shelf, CS%v_shelf) + deallocate(CS%t_shelf, CS%tmask) + deallocate(CS%u_bdry_val, CS%v_bdry_val, CS%t_bdry_val) + deallocate(CS%u_face_mask, CS%v_face_mask) + deallocate(CS%umask, CS%vmask) + + deallocate(CS%ice_visc, CS%taub_beta_eff) + deallocate(CS%OD_rt, CS%OD_av) + deallocate(CS%float_frac, CS%float_frac_rt) + + deallocate(CS) + +end subroutine ice_shelf_dyn_end + + +!> This subroutine updates the vertically averaged ice shelf temperature. +subroutine ice_shelf_temp(CS, ISS, G, time_step, melt_rate, Time) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: melt_rate !< basal melt rate in kg/m^2/s + type(time_type), intent(in) :: Time !< The current model time + +! time_step: time step in sec +! melt_rate: basal melt rate in kg/m^2/s + +! 5/23/12 OVS +! Arguments: +! CS - A structure containing the ice shelf state - including current velocities +! t0 - an array containing temperature at the beginning of the call +! t_after_uflux - an array containing the temperature after advection in u-direction +! t_after_vflux - similar +! +! This subroutine takes the velocity (on the Bgrid) and timesteps +! (HT)_t = - div (uHT) + (adot Tsurd -bdot Tbot) once and then calculates T=HT/H +! +! The flux overflows are included here. That is because they will be used to advect 3D scalars +! into partial cells + + ! + ! flux_enter: this is to capture flow into partially covered cells; it gives the mass flux into a given + ! cell across its boundaries. + ! ###Perhaps flux_enter should be changed into u-face and v-face + ! ###fluxes, which can then be used in halo updates, etc. + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH + real, dimension(SZDI_(G),SZDJ_(G),4) :: flux_enter + integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec + real :: rho, spy, t_bd, Tsurf, adot + + rho = CS%density_ice + spy = 365 * 86400 ! seconds per year; is there a global constant for this? No - it is dependent upon a calendar. + + adot = 0.1/spy ! for now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later + Tsurf = -20.0 + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + flux_enter(:,:,:) = 0.0 + + th_after_uflux(:,:) = 0.0 + th_after_vflux(:,:) = 0.0 + + do j=jsd,jed + do i=isd,ied + t_bd = CS%t_bdry_val(i,j) +! if (ISS%hmask(i,j) > 1) then + if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = CS%t_bdry_val(i,j) + endif + enddo + enddo + + do j=jsd,jed + do i=isd,ied + TH(i,j) = CS%t_shelf(i,j)*ISS%h_shelf(i,j) + enddo + enddo + + +! call enable_averaging(time_step,Time,CS%diag) +! call pass_var(h_after_uflux, G%domain) +! call pass_var(h_after_vflux, G%domain) +! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) +! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) +! call disable_averaging(CS%diag) + + call ice_shelf_advect_temp_x(CS, G, time_step/spy, ISS%hmask, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, G, time_step/spy, ISS%hmask, th_after_uflux, th_after_vflux, flux_enter) + + do j=jsd,jed + do i=isd,ied +! if (ISS%hmask(i,j) == 1) then + if (ISS%h_shelf(i,j) > 0.0) then + CS%t_shelf(i,j) = th_after_vflux(i,j)/ISS%h_shelf(i,j) + else + CS%t_shelf(i,j) = -10.0 + endif + enddo + enddo + + do j=jsd,jed + do i=isd,ied + t_bd = CS%t_bdry_val(i,j) +! if (ISS%hmask(i,j) > 1) then + if ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then + CS%t_shelf(i,j) = t_bd +! CS%t_shelf(i,j) = -15.0 + endif + enddo + enddo + + do j=jsc,jec + do i=isc,iec + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if (ISS%h_shelf(i,j) > 0.0) then +! CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -melt_rate(i,j)*ISS%tfreeze(i,j))/ISS%h_shelf(i,j) + CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -3/spy*ISS%tfreeze(i,j))/ISS%h_shelf(i,j) + else + ! the ice is about to melt away + ! in this case set thickness, area, and mask to zero + ! NOTE: not mass conservative + ! should maybe scale salt & heat flux for this cell + + CS%t_shelf(i,j) = -10.0 + CS%tmask(i,j) = 0.0 + endif + endif + enddo + enddo + + call pass_var(CS%t_shelf, G%domain) + call pass_var(CS%tmask, G%domain) + + if (CS%DEBUG) then + call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3) + endif + +end subroutine ice_shelf_temp + + +subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + 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) :: h0 !< The initial ice shelf thicknesses in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The integrated temperature flux into + !! the cell through the 4 cell boundaries, in degC m3 + + ! 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 + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: u_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + + 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 + + do j=jsd+1,jed-1 + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + + stencil(:) = -1 +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) + do i=is,ie + + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then + + if (i+i_off == G%domain%nihalo+1) then + at_west_bdry=.true. + else + at_west_bdry=.false. + endif + + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then + at_east_bdry=.true. + else + at_east_bdry=.false. + endif + + if (hmask(i,j) == 1) then + + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + + h_after_uflux(i,j) = h0(i,j) + + stencil(:) = h0(i-2:i+2,j) ! fine as long has nx_halo >= 2 + + flux_diff_cell = 0 + + ! 1ST DO LEFT FACE + + if (CS%u_face_mask(i-1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i-1,j) * & + CS%t_bdry_val(i-1,j) / dxdyh +! assume no flux bc for temp +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i-1,j) / dxdyh + + else + + ! get u-velocity at center of left face + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(i-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i-2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(-1) + + endif + + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + + else + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then + flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) + endif + endif + endif + endif + + ! NEXT DO RIGHT FACE + + ! get u-velocity at center of right face + + if (CS%u_face_mask(i+1,j) == 4.) then + + flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_flux_bdry_val(i+1,j) *& + CS%t_bdry_val(i+1,j)/ dxdyh +! assume no flux bc for temp +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i+1,j)/ dxdyh + + else + + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh + + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid + + phi = slope_limiter(stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * stencil(1) + + endif + + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid + + phi = slope_limiter(stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + + else ! h(i+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(i+2) is not + + flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) + + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then + + flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + h_after_uflux(i,j) = h_after_uflux(i,j) + flux_diff_cell + + endif + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i-1,j)* & + CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i-1,j)*CS%t_bdry_val(i-1,j) +! flux_enter(i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i-1,j) +! assume no flux bc for temp + endif + + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then + u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) + flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%t_bdry_val(i+1,j)* & + CS%thickness_bdry_val(i+1,j) + elseif (CS%u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * CS%u_flux_bdry_val(i+1,j) * CS%t_bdry_val(i+1,j) +! assume no flux bc for temp +! flux_enter(i,j,2) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*CS%t_bdry_val(i+1,j) + endif + +! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered +! hmask(i,j) = 2 +! elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered +! hmask(i,j) = 2 + +! endif + + endif + + endif + + enddo ! i loop + + endif + + enddo ! j loop + +end subroutine ice_shelf_advect_temp_x + +subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_after_vflux, flux_enter) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, intent(in) :: time_step !< The time step for this update, in s. + 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_after_uflux !< The ice shelf thicknesses after + !! the zonal mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_after_vflux !< The ice shelf thicknesses after + !! the meridional mass fluxes, in m. + real, dimension(SZDI_(G),SZDJ_(G),4), & + intent(inout) :: flux_enter !< The integrated temperature flux into + !! the cell through the 4 cell boundaries, in degC m3 + + ! 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 + + ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary + ! + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) + ! + ! o--- (4) ---o + ! | | + ! (1) (2) + ! | | + ! o--- (3) ---o + ! + + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i_off, j_off + logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry + real, dimension(-2:2) :: stencil + real :: v_face, & ! positive if out + flux_diff_cell, phi, dxh, dyh, dxdyh + 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 + + do i=isd+2,ied-2 + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries + + stencil(:) = -1 + + do j=js,je + + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then + + if (j+j_off == G%domain%njhalo+1) then + at_south_bdry=.true. + else + at_south_bdry=.false. + endif + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then + at_north_bdry=.true. + else + at_north_bdry=.false. + endif + + if (hmask(i,j) == 1) then + dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) + h_after_vflux(i,j) = h_after_uflux(i,j) + + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 + flux_diff_cell = 0 + + ! 1ST DO south FACE + + if (CS%v_face_mask(i,j-1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j-1) * & + CS%t_bdry_val(i,j-1)/ dxdyh +! assume no flux bc for temp +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j-1) / dxdyh + + else + + ! get u-velocity at center of left face + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + + ! i may not cover all the cases.. but i cover the realistic ones + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh + + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid + + phi = slope_limiter(stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) + + else ! h(j-1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j-2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) + endif + + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter(stencil(0)-stencil(1), stencil(-1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(-1))/2) + else + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then + flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) + endif + + endif + + endif + + endif + + ! NEXT DO north FACE + + if (CS%v_face_mask(i,j+1) == 4.) then + + flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_flux_bdry_val(i,j+1) *& + CS%t_bdry_val(i,j+1)/ dxdyh +! assume no flux bc for temp +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j+1) / dxdyh + + else + + ! get u-velocity at center of right face + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a + ! thickness bdry condition, and the stencil contains it + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid + phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(1) - phi * (stencil(1)-stencil(0))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) + endif + + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid + phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & + (stencil(0) - phi * (stencil(0)-stencil(1))/2) + else ! h(j+1) is valid + ! (o.w. flux would most likely be out of cell) + ! but h(j+2) is not + flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then + flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) + endif + endif + + endif + + endif + + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell + + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then + + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then + v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j-1)* & + CS%thickness_bdry_val(i,j-1) + elseif (CS%v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j-1)*CS%t_bdry_val(i,j-1) +! assume no flux bc for temp +! flux_enter(i,j,3) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j-1) + + endif + + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then + v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%t_bdry_val(i,j+1)* & + CS%thickness_bdry_val(i,j+1) + elseif (CS%v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * CS%v_flux_bdry_val(i,j+1)*CS%t_bdry_val(i,j+1) +! assume no flux bc for temp +! flux_enter(i,j,4) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*CS%t_bdry_val(i,j+1) + endif + +! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing + ! the front without having to call pass_var - if cell is empty and cell to left + ! is ice-covered then this cell will become partly covered + ! hmask(i,j) = 2 + ! elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then + ! this is solely for the purposes of keeping the mask consistent while advancing the + ! front without having to call pass_var - if cell is empty and cell to left is + ! ice-covered then this cell will become partly covered +! hmask(i,j) = 2 +! endif + + endif + endif + enddo ! j loop + endif + enddo ! i loop + +end subroutine ice_shelf_advect_temp_y + +!> \namespace mom_ice_shelf_dynamics +!! +!! \section section_ICE_SHELF_dynamics +!! +!! This module implements the thermodynamic aspects of ocean/ice-shelf +!! inter-actions, along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +!! +!! Derived from code by Chris Little, early 2010. +!! +!! The ice-sheet dynamics subroutines do the following: +!! initialize_shelf_mass - Initializes the ice shelf mass distribution. +!! - Initializes h_shelf, h_mask, area_shelf_h +!! - CURRENTLY: initializes mass_shelf as well, but this is unnecessary, as mass_shelf is initialized based on +!! h_shelf and density_ice immediately afterwards. Possibly subroutine should be renamed +!! update_shelf_mass - updates ice shelf mass via netCDF file +!! USER_update_shelf_mass (TODO). +!! ice_shelf_solve_outer - Orchestrates the calls to calculate the shelf +!! - outer loop calls ice_shelf_solve_inner +!! stresses and checks for error tolerances. +!! Max iteration count for outer loop currently fixed at 100 iteration +!! - tolerance (and error evaluation) can be set through input file +!! - updates u_shelf, v_shelf, ice_visc, taub_beta_eff +!! ice_shelf_solve_inner - Conjugate Gradient solve of matrix solve for ice_shelf_solve_outer +!! - Jacobi Preconditioner - basically diagonal of matrix (not sure if it is effective at all) +!! - modifies u_shelf and v_shelf only +!! - max iteration count can be set through input file +!! - tolerance (and error evaluation) can be set through input file +!! (ISSUE: Too many sum_across_PEs calls?) +!! calc_shelf_driving_stress - Determine the driving stresses using h_shelf, (water) column thickness, bathymetry +!! - does not modify any permanent arrays +!! init_boundary_values - +!! bilinear_shape_functions - shape function for FEM solve using (convex) quadrilateral elements and +!! bilinear nodal basis +!! calc_shelf_visc - Glen's law viscosity and nonlinear sliding law (called by ice_shelf_solve_outer) +!! apply_boundary_values - same as CG_action, but input is zero except for dirichlet bdry conds +!! CG_action - Effect of matrix (that is never explicitly constructed) +!! on vector space of Degrees of Freedom (DoFs) in velocity solve +!! ice_shelf_advect - Given the melt rate and velocities, it advects the ice shelf THICKNESS +!! - modified h_shelf, area_shelf_h, hmask +!! (maybe should updater mass_shelf as well ???) +!! ice_shelf_advect_thickness_x, ice_shelf_advect_thickness_y - These +!! subroutines determine the mass fluxes through the faces. +!! (ISSUE: duplicative flux calls for shared faces?) +!! ice_shelf_advance_front - Iteratively determine the ice-shelf front location. +!! - IF ice_shelf_advect_thickness_x,y are modified to avoid +!! dupe face processing, THIS NEEDS TO BE MODIFIED TOO +!! as it depends on arrays modified in those functions +!! (if in doubt consult DNG) +!! update_velocity_masks - Controls which elements of u_shelf and v_shelf are considered DoFs in linear solve +!! solo_time_step - called only in ice-only mode. +!! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. currently mass_shelf is +!! updated immediately after ice_shelf_advect. +!! +!! +!! NOTES: be aware that hmask(:,:) has a number of functions; it is used for front advancement, +!! for subroutines in the velocity solve, and for thickness boundary conditions (this last one may be removed). +!! in other words, interfering with its updates will have implications you might not expect. +!! +!! Overall issues: Many variables need better documentation and units and the +!! subgrid on which they are discretized. +!! +!! \subsection section_ICE_SHELF_equations ICE_SHELF equations +!! +!! The three fundamental equations are: +!! Heat flux +!! \f[ \qquad \rho_w C_{pw} \gamma_T (T_w - T_b) = \rho_i \dot{m} L_f \f] +!! Salt flux +!! \f[ \qquad \rho_w \gamma_s (S_w - S_b) = \rho_i \dot{m} S_b \f] +!! Freezing temperature +!! \f[ \qquad T_b = a S_b + b + c P \f] +!! +!! where .... +!! +!! \subsection section_ICE_SHELF_references References +!! +!! Asay-Davis, Xylar S., Stephen L. Cornford, Benjamin K. Galton-Fenzi, Rupert M. Gladstone, G. Hilmar Gudmundsson, +!! David M. Holland, Paul R. Holland, and Daniel F. Martin. Experimental design for three interrelated marine ice sheet +!! and ocean model intercomparison projects: MISMIP v. 3 (MISMIP+), ISOMIP v. 2 (ISOMIP+) and MISOMIP v. 1 (MISOMIP1). +!! Geoscientific Model Development 9, no. 7 (2016): 2471. +!! +!! Goldberg, D. N., et al. Investigation of land ice-ocean interaction with a fully coupled ice-ocean model: 1. +!! Model description and behavior. Journal of Geophysical Research: Earth Surface 117.F2 (2012). +!! +!! Goldberg, D. N., et al. Investigation of land ice-ocean interaction with a fully coupled ice-ocean model: 2. +!! Sensitivity to external forcings. Journal of Geophysical Research: Earth Surface 117.F2 (2012). +!! +!! Holland, David M., and Adrian Jenkins. Modeling thermodynamic ice-ocean interactions at the base of an ice shelf. +!! Journal of Physical Oceanography 29.8 (1999): 1787-1800. + +end module MOM_ice_shelf_dynamics diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index bc12e77679..8dcacb3e60 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -11,19 +11,6 @@ module MOM_ice_shelf_initialize implicit none ; private #include -#ifdef SYMMETRIC_LAND_ICE -# define GRID_SYM_ .true. -# define NIMEMQ_IS_ NIMEMQS_ -# define NJMEMQ_IS_ NJMEMQS_ -# define ISUMSTART_INT_ CS%grid%iscq+1 -# define JSUMSTART_INT_ CS%grid%jscq+1 -#else -# define GRID_SYM_ .false. -# define NIMEMQ_IS_ NIMEMQ_ -# define NJMEMQ_IS_ NJMEMQ_ -# define ISUMSTART_INT_ CS%grid%iscq -# define JSUMSTART_INT_ CS%grid%jscq -#endif !MJHpublic initialize_ice_shelf_boundary, initialize_ice_thickness @@ -33,9 +20,15 @@ module MOM_ice_shelf_initialize subroutine initialize_ice_thickness (h_shelf, area_shelf_h, hmask, G, PF) - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters character(len=40) :: mdl = "initialize_ice_thickness" ! This subroutine's name. character(len=200) :: config @@ -58,9 +51,15 @@ end subroutine initialize_ice_thickness subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, PF) - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! This subroutine reads ice thickness and area from a file and puts it into ! h_shelf and area_shelf_h in m (and dimensionless) and updates hmask @@ -108,10 +107,10 @@ subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, ! taper ice shelf in area where there is no sidestress - ! but do not interfere with hmask - if ((G%geoLonCv(i,j) .gt. len_sidestress).and. & - (len_sidestress .gt. 0.)) then + if ((G%geoLonCv(i,j) > len_sidestress).and. & + (len_sidestress > 0.)) then udh = exp (-(G%geoLonCv(i,j)-len_sidestress)/5.0) * h_shelf(i,j) - if (udh .le. 25.0) then + if (udh <= 25.0) then h_shelf(i,j) = 0.0 area_shelf_h (i,j) = 0.0 else @@ -121,11 +120,11 @@ subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, ! update thickness mask - if (area_shelf_h (i,j) .ge. G%areaT(i,j)) then + if (area_shelf_h (i,j) >= G%areaT(i,j)) then hmask(i,j) = 1. - elseif (area_shelf_h (i,j) .eq. 0.0) then + elseif (area_shelf_h (i,j) == 0.0) then hmask(i,j) = 0. - elseif ((area_shelf_h(i,j) .gt. 0) .and. (area_shelf_h(i,j) .le. G%areaT(i,j))) then + elseif ((area_shelf_h(i,j) > 0) .and. (area_shelf_h(i,j) <= G%areaT(i,j))) then hmask(i,j) = 2. else call MOM_error(FATAL,mdl// " AREA IN CELL OUT OF RANGE") @@ -139,9 +138,15 @@ end subroutine initialize_ice_thickness_from_file subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF) - real, intent(inout), dimension(:,:) :: h_shelf, area_shelf_h, hmask - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(param_file_type), intent(in) :: PF + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters character(len=40) :: mdl = "initialize_ice_shelf_thickness_channel" ! This subroutine's name. real :: max_draft, min_draft, flat_shelf_width, c1, slope_pos @@ -176,7 +181,7 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF do i=G%isc,G%iec - if ((j.ge.jsc) .and. (j.le.jec)) then + if ((j >= jsc) .and. (j <= jec)) then if (G%geoLonCu(i-1,j) >= edge_pos) then ! Everything past the edge is open ocean. @@ -209,7 +214,7 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF endif endif - if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then + if ((i+G%idg_offset) == G%domain%nihalo+1) then hmask(i-1,j) = 3.0 endif @@ -218,22 +223,34 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF end subroutine initialize_ice_thickness_channel -!BEGIN MJH subroutine initialize_ice_shelf_boundary ( & -! u_face_mask_boundary, & -! v_face_mask_boundary, & -! u_flux_boundary_values, & -! v_flux_boundary_values, & -! u_boundary_values, & -! v_boundary_values, & -! h_boundary_values, & -! hmask, G, PF) - -! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! real, intent(inout), dimension(SZIB_(G),SZJ_(G)) :: u_face_mask_boundary, u_flux_boundary_values -! real, intent(inout), dimension(SZI_(G),SZJB_(G)) :: v_face_mask_boundary, v_flux_boundary_values -! real, intent(inout), dimension(SZIB_(G),SZJB_(G)) :: u_boundary_values, v_boundary_values -! real, intent(inout), dimension(:,:) :: hmask, h_boundary_values -! type(param_file_type), intent(in) :: PF +!BEGIN MJH +! subroutine initialize_ice_shelf_boundary(u_face_mask_bdry, v_face_mask_bdry, & +! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & +! hmask, G, PF ) + +! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure +! real, dimension(SZIB_(G),SZJ_(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, in m2 s-1. +! real, dimension(SZI_(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, in m2 s-1. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices, in m/yr. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices, in m/yr. +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: hmask !< A mask indicating which tracer points are +! !! partly or fully covered by an ice-shelf +! type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters ! character(len=40) :: mdl = "initialize_ice_shelf_boundary" ! This subroutine's name. ! character(len=200) :: config @@ -248,10 +265,10 @@ end subroutine initialize_ice_thickness_channel ! "flux condition", default=.true.) ! select case ( trim(config) ) -! case ("CHANNEL"); -! call initialize_ice_shelf_boundary_channel(u_face_mask_boundary, & -! v_face_mask_boundary, u_flux_boundary_values, v_flux_boundary_values, & -! u_boundary_values, v_boundary_values, h_boundary_values, hmask, G, & +! case ("CHANNEL") +! call initialize_ice_shelf_boundary_channel(u_face_mask_bdry, & +! v_face_mask_bdry, u_flux_bdry_val, v_flux_bdry_val, & +! u_bdry_val, v_bdry_val, h_bdry_val, hmask, G, & ! flux_bdry, PF) ! case ("FILE"); call MOM_error(FATAL,"MOM_initialize: "// & ! "Unrecognized topography setup "//trim(config)) @@ -263,24 +280,34 @@ end subroutine initialize_ice_thickness_channel ! end subroutine initialize_ice_shelf_boundary -! subroutine initialize_ice_shelf_boundary_channel ( & -! u_face_mask_boundary, & -! v_face_mask_boundary, & -! u_flux_boundary_values, & -! v_flux_boundary_values, & -! u_boundary_values, & -! v_boundary_values, & -! h_boundary_values, & -! hmask, & -! G, flux_bdry, PF ) - -! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure -! real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: u_face_mask_boundary, u_flux_boundary_values -! real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: v_face_mask_boundary, v_flux_boundary_values -! real, dimension(SZIB_(G),SZJB_(G)), intent(inout) :: u_boundary_values, v_boundary_values -! real, dimension(:,:), intent(inout) :: h_boundary_values, hmask -! logical, intent(in) :: flux_bdry -! type (param_file_type), intent(in) :: PF +! subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & +! u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, h_bdry_val, & +! hmask, G, flux_bdry, PF ) + +! type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure +! real, dimension(SZIB_(G),SZJ_(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, in m2 s-1. +! real, dimension(SZI_(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, in m2 s-1. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices, in m/yr. +! real, dimension(SZIB_(G),SZJB_(G)), & +! intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices, in m/yr. +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries +! real, dimension(SZDI_(G),SZDJ_(G)), & +! intent(inout) :: hmask !< A mask indicating which tracer points are +! !! partly or fully covered by an ice-shelf +! logical, intent(in) :: flux_bdry !< If true, use mass fluxes as the boundary value. +! 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, isc, jsc, iec, jec, ied, jed @@ -311,41 +338,41 @@ end subroutine initialize_ice_thickness_channel ! ! upstream boundary - set either dirichlet or flux condition -! if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then +! if ((i+G%idg_offset) == G%domain%nihalo+1) then ! if (flux_bdry) then -! u_face_mask_boundary (i-1,j) = 4.0 -! u_flux_boundary_values (i-1,j) = input_flux +! u_face_mask_bdry(i-1,j) = 4.0 +! u_flux_bdry_val(i-1,j) = input_flux ! else ! hmask(i-1,j) = 3.0 -! h_boundary_values (i-1,j) = input_thick -! u_face_mask_boundary (i-1,j) = 3.0 -! u_boundary_values (i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*lenlat)*2./lenlat)**2) * & +! h_bdry_val(i-1,j) = input_thick +! u_face_mask_bdry(i-1,j) = 3.0 +! u_bdry_val(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*lenlat)*2./lenlat)**2) * & ! 1.5 * input_flux / input_thick -! u_boundary_values (i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*lenlat)*2./lenlat)**2) * & +! u_bdry_val(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*lenlat)*2./lenlat)**2) * & ! 1.5 * input_flux / input_thick ! endif ! endif ! ! side boundaries: no flow -! if (G%jdg_offset+j .eq. gjsc+1) then !bot boundary -! if (len_stress .eq. 0. .OR. G%geoLonCv(i,j-1) .le. len_stress) then -! v_face_mask_boundary (i,j-1) = 0. +! if (G%jdg_offset+j == gjsc+1) then !bot boundary +! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then +! v_face_mask_bdry(i,j-1) = 0. ! else -! v_face_mask_boundary (i,j-1) = 1. +! v_face_mask_bdry(i,j-1) = 1. ! endif -! elseif (G%jdg_offset+j .eq. gjec) then !top boundary -! if (len_stress .eq. 0. .OR. G%geoLonCv(i,j-1) .le. len_stress) then -! v_face_mask_boundary (i,j) = 0. +! elseif (G%jdg_offset+j == gjec) then !top boundary +! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then +! v_face_mask_bdry(i,j) = 0. ! else -! v_face_mask_boundary (i,j) = 1. +! v_face_mask_bdry(i,j) = 1. ! endif ! endif ! ! downstream boundary - CFBC -! if (i+G%idg_offset .eq. giec) then -! u_face_mask_boundary(i,j) = 2.0 +! if (i+G%idg_offset == giec) then +! u_face_mask_bdry(i,j) = 2.0 ! endif ! enddo diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 new file mode 100644 index 0000000000..fe9ec8d74b --- /dev/null +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -0,0 +1,101 @@ +!> Implements the thermodynamic aspects of ocean / ice-shelf interactions, +!! along with a crude placeholder for a later implementation of full +!! ice shelf dynamics, all using the MOM framework and coding style. +module MOM_ice_shelf_state + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE +use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type +use MOM_grid, only : MOM_grid_init, ocean_grid_type +use MOM_get_input, only : directories, Get_MOM_input +use mpp_mod, only : mpp_sum, mpp_max, mpp_min, mpp_pe, mpp_npes, mpp_sync +use MOM_coms, only : reproducing_sum +use MOM_checksums, only : hchksum, qchksum, chksum, uchksum, vchksum, uvchksum + +implicit none ; private + +public ice_shelf_state_end, ice_shelf_state_init + +!> Structure that describes the ice shelf state +type, public :: ice_shelf_state + real, pointer, dimension(:,:) :: & + mass_shelf => NULL(), & !< The mass per unit area of the ice shelf or sheet, in kg m-2. + area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf, in m2. + h_shelf => NULL(), & !< the thickness of the shelf in m, redundant with mass but may + !! make the code more readable + hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells + !! 1: fully covered, solve for velocity here (for now all + !! ice-covered cells are treated the same, this may change) + !! 2: partially covered, do not solve for velocity + !! 0: no ice in cell. + !! 3: bdry condition on thickness set - not in computational domain + !! -2 : default (out of computational boundary, and) not = 3 + !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED + !! otherwise the wrong nodes will be included in velocity calcs. + + tflux_ocn => NULL(), & !< The UPWARD sensible ocean heat flux at the + !! ocean-ice interface, in W m-2. + salt_flux => NULL(), & !< The downward salt flux at the ocean-ice + !! interface, in kg m-2 s-1. + water_flux => NULL(), & !< The net downward liquid water flux at the + !! ocean-ice interface, in kg m-2 s-1. + tflux_shelf => NULL(), & !< The UPWARD diffusive heat flux in the ice + !! shelf at the ice-ocean interface, in W m-2. + + tfreeze => NULL() !< The freezing point potential temperature + !! an the ice-ocean interface, in deg C. + +end type ice_shelf_state + +contains + +!> Deallocates all memory associated with this module +subroutine ice_shelf_state_init(ISS, G) + type(ice_shelf_state), pointer :: ISS !< A pointer to the ice shelf state structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + + integer :: isd, ied, jsd, jed + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + + if (associated(ISS)) then + call MOM_error(FATAL, "MOM_ice_shelf_state.F90, ice_shelf_state_init: "// & + "called with an associated ice_shelf_state pointer.") + return + endif + allocate(ISS) + + allocate(ISS%mass_shelf(isd:ied,jsd:jed) ) ; ISS%mass_shelf(:,:) = 0.0 + allocate(ISS%area_shelf_h(isd:ied,jsd:jed) ) ; ISS%area_shelf_h(:,:) = 0.0 + allocate(ISS%h_shelf(isd:ied,jsd:jed) ) ; ISS%h_shelf(:,:) = 0.0 + allocate(ISS%hmask(isd:ied,jsd:jed) ) ; ISS%hmask(:,:) = -2.0 + + allocate(ISS%tflux_ocn(isd:ied,jsd:jed) ) ; ISS%tflux_ocn(:,:) = 0.0 + allocate(ISS%water_flux(isd:ied,jsd:jed) ) ; ISS%water_flux(:,:) = 0.0 + allocate(ISS%salt_flux(isd:ied,jsd:jed) ) ; ISS%salt_flux(:,:) = 0.0 + allocate(ISS%tflux_shelf(isd:ied,jsd:jed) ) ; ISS%tflux_shelf(:,:) = 0.0 + allocate(ISS%tfreeze(isd:ied,jsd:jed) ) ; ISS%tfreeze(:,:) = 0.0 + +end subroutine ice_shelf_state_init + + +!> Deallocates all memory associated with this module +subroutine ice_shelf_state_end(ISS) + type(ice_shelf_state), pointer :: ISS !< A pointer to the ice shelf state structure + + if (.not.associated(ISS)) return + + deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%hmask) + + deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) + deallocate(ISS%tfreeze) + + deallocate(ISS) + +end subroutine ice_shelf_state_end + + +end module MOM_ice_shelf_state diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 new file mode 100644 index 0000000000..343aacd452 --- /dev/null +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -0,0 +1,209 @@ +!> Routines incorporating the effects of marine ice (sea-ice and icebergs) into +!! the ocean model dynamics and thermodynamics. +module MOM_marine_ice + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_constants, only : hlf +use MOM_diag_mediator, only : post_data, query_averaging_enabled, diag_ctrl +use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE +use MOM_domains, only : TO_ALL, Omit_Corners +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : allocate_forcing_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_time_manager, only : time_type +use MOM_variables, only : surface + +implicit none ; private + +#include + +public iceberg_forces, iceberg_fluxes, marine_ice_init + +!> Control structure for MOM_marine_ice +type, public :: marine_ice_CS ; private + real :: kv_iceberg !< The viscosity of the icebergs in m2/s (for ice rigidity) + real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy + !! so that fluxes below are set to zero. (0.5 is a + !! good value to use.) Not applied for negative values. + real :: latent_heat_fusion !< Latent heat of fusion + real :: density_iceberg !< A typical density of icebergs in kg/m3 (for ice rigidity) + + type(time_type), pointer :: Time !< A pointer to the ocean model's clock. + type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. +end type marine_ice_CS + +contains + +!> add_berg_flux_to_shelf adds rigidity and ice-area coverage due to icebergs +!! to the forces type fields, and adds ice-areal coverage and modifies various +!! thermodynamic fluxes due to the presence of icebergs. +subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, & + time_step, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(mech_forcing), intent(inout) :: forces !< A structure with the driving mechanical forces + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. + real, intent(in) :: time_step !< The coupling time step, in s. + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + + real :: kv_rho_ice ! The viscosity of ice divided by its density, in m5 kg-1 s-1. + integer :: i, j, is, ie, js, je + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + !This routine adds iceberg data to the ice shelf data (if ice shelf is used) + !which can then be used to change the top of ocean boundary condition used in + !the ocean model. This routine is taken from the add_shelf_flux subroutine + !within the ice shelf model. + + if (.not.associated(CS)) return + + if (.not.(associated(forces%area_berg) .and. associated(forces%mass_berg) ) ) return + + if (.not.(associated(forces%frac_shelf_u) .and. associated(forces%frac_shelf_v) .and. & + associated(forces%rigidity_ice_u) .and. associated(forces%rigidity_ice_v)) ) return + + ! This section sets or augments the values of fields in forces. + if (.not. use_ice_shelf) then + forces%frac_shelf_u(:,:) = 0.0 ; forces%frac_shelf_v(:,:) = 0.0 + endif + if (.not. forces%accumulate_rigidity) then + forces%rigidity_ice_u(:,:) = 0.0 ; forces%rigidity_ice_v(:,:) = 0.0 + endif + + call pass_var(forces%area_berg, G%domain, TO_ALL+Omit_corners, halo=1, complete=.false.) + call pass_var(forces%mass_berg, G%domain, TO_ALL+Omit_corners, halo=1, complete=.true.) + kv_rho_ice = CS%kv_iceberg / CS%density_iceberg + do j=js,je ; do I=is-1,ie + if ((G%areaT(i,j) + G%areaT(i+1,j) > 0.0)) & ! .and. (G%dxdy_u(I,j) > 0.0)) & + forces%frac_shelf_u(I,j) = forces%frac_shelf_u(I,j) + & + (((forces%area_berg(i,j)*G%areaT(i,j)) + & + (forces%area_berg(i+1,j)*G%areaT(i+1,j))) / & + (G%areaT(i,j) + G%areaT(i+1,j)) ) + forces%rigidity_ice_u(I,j) = forces%rigidity_ice_u(I,j) + kv_rho_ice * & + min(forces%mass_berg(i,j), forces%mass_berg(i+1,j)) + enddo ; enddo + do J=js-1,je ; do i=is,ie + if ((G%areaT(i,j) + G%areaT(i,j+1) > 0.0)) & ! .and. (G%dxdy_v(i,J) > 0.0)) & + forces%frac_shelf_v(i,J) = forces%frac_shelf_v(i,J) + & + (((forces%area_berg(i,j)*G%areaT(i,j)) + & + (forces%area_berg(i,j+1)*G%areaT(i,j+1))) / & + (G%areaT(i,j) + G%areaT(i,j+1)) ) + forces%rigidity_ice_v(i,J) = forces%rigidity_ice_v(i,J) + kv_rho_ice * & + min(forces%mass_berg(i,j), forces%mass_berg(i,j+1)) + enddo ; enddo + !### This halo update may be unnecessary. Test it. -RWH + call pass_vector(forces%frac_shelf_u, forces%frac_shelf_v, G%domain, TO_ALL, CGRID_NE) + +end subroutine iceberg_forces + +!> iceberg_fluxes adds ice-area-coverage and modifies various +!! thermodynamic fluxes due to the presence of icebergs. +subroutine iceberg_fluxes(G, fluxes, use_ice_shelf, sfc_state, & + time_step, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(forcing), intent(inout) :: fluxes !< A structure with pointers to themodynamic, + !! tracer and mass exchange forcing fields + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. + real, intent(in) :: time_step !< The coupling time step, in s. + type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice + + real :: fraz ! refreezing rate in kg m-2 s-1 + real :: I_dt_LHF ! The inverse of the timestep times the latent heat of fusion, in kg J-1 s-1. + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed + !This routine adds iceberg data to the ice shelf data (if ice shelf is used) + !which can then be used to change the top of ocean boundary condition used in + !the ocean model. This routine is taken from the add_shelf_flux subroutine + !within the ice shelf model. + + if (.not.associated(CS)) return + if (.not.(associated(fluxes%area_berg) .and. associated(fluxes%ustar_berg) .and. & + associated(fluxes%mass_berg) ) ) return + if (.not.(associated(fluxes%frac_shelf_h) .and. associated(fluxes%ustar_shelf)) ) return + + + if (.not.(associated(fluxes%area_berg) .and. associated(fluxes%ustar_berg) .and. & + associated(fluxes%mass_berg) ) ) return + if (.not. use_ice_shelf) then + fluxes%frac_shelf_h(:,:) = 0. + fluxes%ustar_shelf(:,:) = 0. + endif + do j=jsd,jed ; do i=isd,ied ; if (G%areaT(i,j) > 0.0) then + fluxes%frac_shelf_h(i,j) = fluxes%frac_shelf_h(i,j) + fluxes%area_berg(i,j) + fluxes%ustar_shelf(i,j) = fluxes%ustar_shelf(i,j) + fluxes%ustar_berg(i,j) + endif ; enddo ; enddo + + !Zero'ing out other fluxes under the tabular icebergs + if (CS%berg_area_threshold >= 0.) then + I_dt_LHF = 1.0 / (time_step * CS%latent_heat_fusion) + do j=jsd,jed ; do i=isd,ied + if (fluxes%frac_shelf_h(i,j) > CS%berg_area_threshold) then + ! Only applying for ice shelf covering most of cell. + + if (associated(fluxes%sw)) fluxes%sw(i,j) = 0.0 + if (associated(fluxes%lw)) fluxes%lw(i,j) = 0.0 + if (associated(fluxes%latent)) fluxes%latent(i,j) = 0.0 + if (associated(fluxes%evap)) fluxes%evap(i,j) = 0.0 + + ! Add frazil formation diagnosed by the ocean model (J m-2) in the + ! form of surface layer evaporation (kg m-2 s-1). Update lprec in the + ! control structure for diagnostic purposes. + + if (associated(sfc_state%frazil)) then + fraz = sfc_state%frazil(i,j) * I_dt_LHF + if (associated(fluxes%evap)) fluxes%evap(i,j) = fluxes%evap(i,j) - fraz + !CS%lprec(i,j)=CS%lprec(i,j) - fraz + sfc_state%frazil(i,j) = 0.0 + endif + + !Alon: Should these be set to zero too? + if (associated(fluxes%sens)) fluxes%sens(i,j) = 0.0 + if (associated(fluxes%salt_flux)) fluxes%salt_flux(i,j) = 0.0 + if (associated(fluxes%lprec)) fluxes%lprec(i,j) = 0.0 + endif + enddo ; enddo + endif + +end subroutine iceberg_fluxes + +!> Initialize control structure for MOM_marine_ice +subroutine marine_ice_init(Time, G, param_file, diag, CS) + type(time_type), target, intent(in) :: Time !< Current model time + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + 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" + character(len=40) :: mdl = "MOM_marine_ice" ! This module's name. + + if (associated(CS)) then + call MOM_error(WARNING, "marine_ice_init called with an "// & + "associated control structure.") + return + else ; allocate(CS) ; endif + + ! Write all relevant parameters to the model log. + call log_version(mdl, version) + + call get_param(param_file, mdl, "KV_ICEBERG", CS%kv_iceberg, & + "The viscosity of the icebergs", units="m2 s-1",default=1.0e10) + call get_param(param_file, mdl, "DENSITY_ICEBERGS", CS%density_iceberg, & + "A typical density of icebergs.", units="kg m-3", default=917.0) + call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & + "The latent heat of fusion.", units="J/kg", default=hlf) + call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & + "Fraction of grid cell which iceberg must occupy, so that fluxes \n"//& + "below berg are set to zero. Not applied for negative \n"//& + "values.", units="non-dim", default=-1.0) + +end subroutine marine_ice_init + +end module MOM_marine_ice diff --git a/src/ice_shelf/shelf_triangular_FEstuff.F90 b/src/ice_shelf/shelf_triangular_FEstuff.F90 deleted file mode 100644 index 72c0043ebf..0000000000 --- a/src/ice_shelf/shelf_triangular_FEstuff.F90 +++ /dev/null @@ -1,727 +0,0 @@ -module shelf_triangular_FEstuff - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_diag_mediator, only : diag_ctrl, time_type, enable_averaging, disable_averaging -use MOM_grid, only : ocean_grid_type -use MOM_time_manager, only : time_type, set_time, time_type_to_real -use MOM_restart, only : restart_init, restore_state, MOM_restart_CS -use MOM_EOS, only : EOS_type -use user_shelf_init, only : user_ice_shelf_CS - -implicit none ; private - -#include -type, public :: ice_shelf_CS ; private - type(MOM_restart_CS), pointer :: restart_CSp => NULL() - type(ocean_grid_type) :: grid ! A structure containing metrics, etc. - ! The rest is private - character(len=128) :: restart_output_dir = ' ' - real, pointer, dimension(:,:) :: & - mass_shelf => NULL(), & ! The mass per unit area of the ice shelf or sheet, in kg m-2. - area_shelf_h => NULL(), & ! The area per cell covered by the ice shelf, in m2. - - t_flux => NULL(), & ! The UPWARD sensible ocean heat flux at the ocean-ice - ! interface, in W m-2. - salt_flux => NULL(), & ! The downward salt flux at the ocean-ice interface, in kg m-2 s-1. - lprec => NULL(), & ! The downward liquid water flux at the ocean-ice interface, - ! in kg m-2 s-1. - ! Perhaps these diagnostics should only be kept with the call? - exch_vel_t => NULL(), & - exch_vel_s => NULL(), & - tfreeze => NULL(), & ! The freezing point potential temperature an the ice-ocean - ! interface, in deg C. - tflux_shelf => NULL(), & ! The UPWARD diffusive heat flux in the ice shelf at the - ! ice-ocean interface, in W m-2. -!!! DNG !!! - u_shelf => NULL(), & ! the zonal (?) velocity of the ice shelf/sheet... in meters per second??? - ! on q-points (B grid) - v_shelf => NULL(), & ! the meridional velocity of the ice shelf/sheet... m/s ?? - ! on q-points (B grid) - h_shelf => NULL(), & ! the thickness of the shelf in m... redundant with mass - ! but may make code more readable - hmask => NULL(),& ! used to indicate ice-covered cells, as well as partially-covered - ! 1: fully covered, solve for velocity here - ! (for now all ice-covered cells are treated the same, this may change) - ! 2: partially covered, do not solve for velocity - ! 0: no ice in cell. - ! 3: bdry condition on thickness set - not in computational domain - ! -2 : default (out of computational boundary, and not = 3 - - ! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED - ! otherwise the wrong nodes will be included in velocity calcs. - u_face_mask => NULL(), v_face_mask => NULL(), & - ! masks for velocity boundary conditions - on *C GRID* - this is because the FEM solution - ! cares about FACES THAT GET INTEGRATED OVER, not vertices - ! Will represent boundary conditions on computational boundary (or permanent boundary - ! between fast-moving and near-stagnant ice - ! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, 3=inhomogeneous dirichlet boundary - umask => NULL(), vmask => NULL(), & - ! masks on the actual degrees of freedom (B grid) - - ! 1=normal node, 3=inhomogeneous boundary node, 0 - no flow node (will also get ice-free nodes) - ice_visc_bilinear => NULL(), & - ice_visc_lower_tri => NULL(), & - ice_visc_upper_tri => NULL(), & - thickness_boundary_values => NULL(), & - u_boundary_values => NULL(), & - v_boundary_values => NULL(), & - - - taub_beta_eff_bilinear => NULL(), & ! nonlinear part of "linearized" basal stress - exact form depends on basal law exponent - ! and/or whether flow is "hybridized" a la Goldberg 2011 - taub_beta_eff_lower_tri => NULL(), & - taub_beta_eff_upper_tri => NULL(), & - - OD_rt => NULL(), float_frac_rt => NULL(), & - OD_av => NULL(), float_frac => NULL() !! two arrays that represent averages of ocean values that are maintained - !! within the ice shelf module and updated based on the "ocean state". - !! OD_av is ocean depth, and float_frac is the average amount of time - !! a cell is "exposed", i.e. the column thickness is below a threshold. - !! both are averaged over the time of a diagnostic (ice velocity) - - !! [if float_frac = 1 ==> grounded; obv. counterintuitive; might fix] - - real :: ustar_bg ! A minimum value for ustar under ice shelves, in m s-1. - real :: Cp ! The heat capacity of sea water, in J kg-1 K-1. - real :: Cp_ice ! The heat capacity of fresh ice, in J kg-1 K-1. - real :: gamma_t ! The (fixed) turbulent exchange velocity in the - ! 2-equation formulation, in m s-1. - real :: Salin_ice ! The salinity of shelf ice, in PSU. - real :: Temp_ice ! The core temperature of shelf ice, in C. - real :: kv_ice ! The viscosity of ice, in m2 s-1. - real :: density_ice ! A typical density of ice, in kg m-3. - real :: kv_molec ! The molecular kinematic viscosity of sea water, m2 s-1. - real :: kd_molec_salt ! The molecular diffusivity of salt, in m2 s-1. - real :: kd_molec_temp ! The molecular diffusivity of heat, in m2 s-1. - real :: Lat_fusion ! The latent heat of fusion, in J kg-1. - -!!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! - - real :: time_step ! this is the shortest timestep that the ice shelf sees, 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. - -!!! all need to be initialized - - real :: A_glen_isothermal - real :: n_glen - real :: eps_glen_min - real :: C_basal_friction - real :: n_basal_friction - real :: density_ocean_avg ! this does not affect ocean circulation OR thermodynamics - ! it is to estimate the gravitational driving force at the shelf front - ! (until we think of a better way to do it- but any difference will be negligible) - real :: thresh_float_col_depth ! the water column depth over which the shelf if considered to be floating - real :: input_flux - real :: input_thickness - - real :: len_lat ! this really should be a Grid or Domain field - - - real :: velocity_update_time_step ! the time to update the velocity through the nonlinear - ! elliptic equation. i think this should be done no more often than - ! ~ once a day (maybe longer) because it will depend on ocean values - ! that are averaged over this time interval, and the solve will begin - ! to lose meaning if it is done too frequently - integer :: velocity_update_sub_counter ! there is no outer loop for the velocity solve; the counter will have to be stored - integer :: velocity_update_counter ! the "outer" timestep number - integer :: nstep_velocity ! ~ (velocity_update_time_step / time_step) - - real :: cg_tolerance, nonlinear_tolerance - integer :: cg_max_iterations - integer :: nonlin_solve_err_mode ! 1: exit vel solve based on nonlin residual - ! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol where | | is infty-norm - real :: CFL_factor ! in uncoupled run, how to limit subcycled advective timestep - ! i.e. dt = CFL_factor * min (dx / u) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - type(time_type) :: Time ! The component's time. - type(EOS_type), pointer :: eqn_of_state => NULL() ! Type that indicates the - ! equation of state to use. - logical :: isshelf ! True if a shelf model is to be used. - logical :: shelf_mass_is_dynamic ! True if the ice shelf mass changes with - ! time. - 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 mass with - ! the underlying ocean. - logical :: threeeq ! If true, the 3 equation consistency equations are - ! used to calculate the flux at the ocean-ice interface. - integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & - id_tfreeze = -1, id_tfl_shelf = -1, & - id_u_shelf = -1, id_v_shelf = -1, id_h_shelf = -1, id_h_mask = -1, & - id_u_mask = -1, id_v_mask = -1, & - id_surf_elev = -1, id_bathym = -1, id_float_frac = -1, id_col_thick = -1, & - id_area_shelf_h = -1, id_OD_rt = -1, id_float_frac_rt = -1 - type(diag_ctrl) :: diag ! A structure that is used to control diagnostic - ! output. - type(user_ice_shelf_CS), pointer :: user_CS => NULL() - - logical :: write_output_to_file ! this is for seeing arrays w/out netcdf capability -end type ice_shelf_CS -contains - -subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) - - type(ice_shelf_CS), pointer :: CS - real, dimension (:,:), intent(inout) :: u_diagonal, v_diagonal - -! returns the diagonal entries of the matrix for a Jacobi preconditioning - - real, pointer, dimension (:,:) :: umask, vmask, & - nu_lower, nu_upper, beta_lower, beta_upper, hmask - type(ocean_grid_type), pointer :: G - integer :: i, j, is, js, cnt, isc, jsc, iec, jec - real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - G => CS%grid - -! if (G%symmetric) then -! isym=1 -! else -! isym=0 -! endif - - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then - dxh = G%dxT(i,j) - dyh = G%dyT(i,j) - dxdyh = G%areaT(i,j) - - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - ux = 1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 1./dxh ; vy = 0./dyh - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 0./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - ux = 0./dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = 0. ; uy = 0. - vx = 0./dxh ; vy = 1./dyh - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - ux = -1./dxh ; uy = 0./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = 0./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - ux = -1./dxh ; uy = -1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - - vx = -1./dxh ; vy = -1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - beta_lower(i,j) * dxdyh * 1./24 - endif - - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - ux = 1./ dxh ; uy = 1./dyh - vx = 0. ; vy = 0. - - u_diagonal (i,j) = u_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - u_diagonal (i,j) = u_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - vx = 1./ dxh ; vy = 1./dyh - ux = 0. ; uy = 0. - - v_diagonal (i,j) = v_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - v_diagonal (i,j) = v_diagonal (i,j) + & - beta_upper(i,j) * dxdyh * 1./24 - - endif - endif ; enddo ; enddo - -end subroutine matrix_diagonal_triangle - -!~ subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundary_contr) - - !~ type(time_type), intent(in) :: Time - !~ type(ice_shelf_CS), pointer :: CS - !~ real, dimension (:,:), intent(inout) :: u_boundary_contr, v_boundary_contr - -!~ ! this will be a per-setup function. the boundary values of thickness and velocity -!~ ! (and possibly other variables) will be updated in this function - - !~ real, pointer, dimension (:,:) :: u_boundary_values, & - !~ v_boundary_values, & - !~ umask, vmask, hmask, & - !~ nu_lower, nu_upper, beta_lower, beta_upper - !~ type(ocean_grid_type), pointer :: G - !~ integer :: 0, i, j, cnt, isc, jsc, iec, jec - !~ real :: A, n, ux, uy, vx, vy, eps_min, domain_width, dxh, dyh, dxdyh - - !~ G => CS%grid - -!~ ! if (G%symmetric) then -!~ ! isym=1 -!~ ! else -!~ ! isym=0 -!~ ! endif - - - - !~ isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - !~ u_boundary_values => CS%u_boundary_values - !~ v_boundary_values => CS%v_boundary_values - !~ umask => CS%umask ; vmask => CS%vmask ; hmask => CS%hmask - !~ nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri - !~ beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - - !~ domain_width = CS%len_lat - - !~ do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then - - !~ if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ ux = (u_boundary_values(i,j-1)-u_boundary_values(i-1,j-1))/dxh - !~ vx = (v_boundary_values(i,j-1)-v_boundary_values(i-1,j-1))/dxh - !~ uy = (u_boundary_values(i-1,j)-u_boundary_values(i-1,j-1))/dyh - !~ vy = (v_boundary_values(i-1,j)-v_boundary_values(i-1,j-1))/dyh - - !~ if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - - !~ v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - - !~ v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - - !~ u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & - !~ u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & - !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) - !~ endif - - !~ endif - - !~ if ((umask(i,j) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ ux = (u_boundary_values(i,j)-u_boundary_values(i-1,j))/dxh - !~ vx = (v_boundary_values(i,j)-v_boundary_values(i-1,j))/dxh - !~ uy = (u_boundary_values(i,j)-u_boundary_values(i,j-1))/dyh - !~ vy = (v_boundary_values(i,j)-v_boundary_values(i,j-1))/dyh - - !~ if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - !~ u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - - !~ v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - - !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - !~ if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - !~ u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - - !~ v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - !~ .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - - !~ u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - - !~ v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - !~ beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & - !~ u_boundary_values(i-1,j) + & - !~ u_boundary_values(i,j-1)) - !~ endif - - - !~ endif - !~ endif ; enddo ; enddo - -!~ end subroutine apply_boundary_values_triangle - -!~ subroutine calc_shelf_visc_triangular (CS,u,v) - !~ type(ice_shelf_CS), pointer :: CS - !~ real, dimension(:,:), intent(inout) :: u, v - -!~ ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for triangle FEM solve so there is -!~ ! an "upper" and "lower" triangular viscosity - -!~ ! also this subroutine updates the nonlinear part of the basal traction - -!~ ! this may be subject to change later... to make it "hybrid" - - !~ real, pointer, dimension (:,:) :: nu_lower , & - !~ nu_upper, & - !~ beta_eff_lower, & - !~ beta_eff_upper - !~ real, pointer, dimension (:,:) :: H, &! thickness - !~ hmask - - !~ type(ocean_grid_type), pointer :: G - !~ integer :: 0, i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js - !~ real :: A, n, ux, uy, vx, vy, eps_min, umid, vmid, unorm, C_basal_friction, n_basal_friction, dxh, dyh, dxdyh - - !~ G => CS%grid - - !~ isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - !~ iscq = G%iscq ; iecq = G%iecq ; jscq = G%jscq ; jecq = G%jecq - !~ isd = G%isd ; jsd = G%jsd ; ied = G%isd ; jed = G%jsd - !~ iegq = G%iegq ; jegq = G%jegq - !~ gisc = G%domain%nx_halo+1 ; gjsc = G%domain%ny_halo+1 - !~ giec = G%domain%nxtot+gisc ; gjec = G%domain%nytot+gjsc - !~ is = iscq - (1-0); js = jscq - (1-0) - - !~ A = CS%A_glen_isothermal ; n = CS%n_glen; eps_min = CS%eps_glen_min - - !~ H => CS%h_shelf - !~ hmask => CS%hmask - !~ nu_upper => CS%ice_visc_upper_tri - !~ nu_lower => CS%ice_visc_lower_tri - !~ beta_eff_upper => CS%taub_beta_eff_upper_tri - !~ beta_eff_lower => CS%taub_beta_eff_lower_tri - - !~ C_basal_friction = CS%C_basal_friction ; n_basal_friction = CS%n_basal_friction - - !~ do i=isd,ied - !~ do j=jsd,jed - - !~ dxh = G%dxh(i,j) - !~ dyh = G%dyh(i,j) - !~ dxdyh = G%dxdyh(i,j) - - !~ if (hmask (i,j) .eq. 1) then - !~ ux = (u(i,j-1)-u(i-1,j-1)) / dxh - !~ vx = (v(i,j-1)-v(i-1,j-1)) / dxh - !~ uy = (u(i-1,j)-u(i-1,j-1)) / dyh - !~ vy = (v(i-1,j)-v(i-1,j-1)) / dyh - - !~ nu_lower(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - !~ umid = 1./3 * (u(i-1,j-1)+u(i-1,j)+u(i,j-1)) - !~ vmid = 1./3 * (v(i-1,j-1)+v(i-1,j)+v(i,j-1)) - !~ unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta_eff_lower (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - !~ ux = (u(i,j)-u(i-1,j)) / dxh - !~ vx = (v(i,j)-v(i-1,j)) / dxh - !~ uy = (u(i,j)-u(i,j-1)) / dyh - !~ vy = (u(i,j)-u(i,j-1)) / dyh - - !~ nu_upper(i,j) = A**(-1/n) * (ux**2+vy**2+ux*vy.25*(uy+vx)**2+eps_min**2) ** ((1-n)/(2*n)) * H(i,j) - !~ umid = 1./3 * (u(i,j)+u(i-1,j)+u(i,j-1)) - !~ vmid = 1./3 * (v(i,j)+v(i-1,j)+v(i,j-1)) - !~ unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta_eff_upper (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) - - !~ endif - !~ enddo - !~ enddo - -!~ end subroutine calc_shelf_visc_triangular - - -!~ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper, nu_lower, & - !~ beta_upper, beta_lower, dxh, dyh, dxdyh, is, ie, js, je, 0) - -!~ real, dimension (:,:), intent (inout) :: uret, vret -!~ real, dimension (:,:), intent (in) :: u, v -!~ real, dimension (:,:), intent (in) :: umask, vmask -!~ real, dimension (:,:), intent (in) :: hmask, nu_upper, nu_lower, beta_upper, beta_lower -!~ real, dimension (:,:), intent (in) :: dxh, dyh, dxdyh -!~ integer, intent(in) :: is, ie, js, je, 0 - -!~ ! the linear action of the matrix on (u,v) with triangular finite elements -!~ ! as of now everything is passed in so no grid pointers or anything of the sort have to be dereferenced, -!~ ! but this may change pursuant to conversations with others -!~ ! -!~ ! is & ie are the cells over which the iteration is done; this may change between calls to this subroutine -!~ ! in order to make less frequent halo updates -!~ ! isym = 1 if grid is symmetric, 0 o.w. - - !~ real :: ux, uy, vx, vy - !~ integer :: i,j - - !~ do i=is,ie - !~ do j=js,je - - !~ if (hmask(i,j) .eq. 1) then ! this cell's vertices contain degrees of freedom - - !~ ux = (u(i,j-1)-u(i-1,j-1))/dxh(i,j) - !~ vx = (v(i,j-1)-v(i-1,j-1))/dxh(i,j) - !~ uy = (u(i-1,j)-u(i-1,j-1))/dyh(i,j) - !~ vy = (v(i-1,j)-v(i-1,j-1))/dyh(i,j) - - !~ if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - !~ if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - !~ uret(i-1,j) = uret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - !~ vret(i-1,j) = vret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - !~ if (umask(i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node - - !~ uret(i-1,j-1) = uret(i-1,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - !~ vret(i-1,j-1) = vret(i-1,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - !~ uret(i-1,j-1) = uret(i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i-1,j-1) = vret(i-1,j-1) + & - !~ beta_lower(i,j) * dxdyh(i,j) * 1./24 * (v(i-1,j-1) + & - !~ v(i-1,j) + v(i,j-1)) - !~ endif - - - !~ ux = (u(i,j)-u(i-1,j))/dxh(i,j) - !~ vx = (v(i,j)-v(i-1,j))/dxh(i,j) - !~ uy = (u(i,j)-u(i,j-1))/dyh(i,j) - !~ vy = (v(i,j)-v(i,j-1))/dyh(i,j) - - !~ if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node - - !~ uret(i-1,j) = uret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) - - !~ vret(i-1,j) = vret(i-1,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) - - !~ uret(i,j-1) = uret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j-1) = vret(i,j-1) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ if (umask(i,j) .eq. 1) then ! this (top right) is a degree of freedom node - - !~ uret(i,j) = uret(i,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) - - !~ vret(i,j) = vret(i,j) + & - !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) - - !~ uret(i,j) = uret(i,j) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - - !~ vret(i,j) = vret(i,j) + & - !~ beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & - !~ u(i-1,j) + u(i,j-1)) - !~ endif - - !~ endif - - !~ enddo - !~ enddo - -!~ end subroutine CG_action_triangular - - -END MODULE shelf_triangular_FEstuff diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index b7820dd43d..dfd527169d 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -1,79 +1,17 @@ +!> This module specifies the initial values and evolving properties of the +!! MOM6 ice shelf, using user-provided code. module user_shelf_init ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - June 2002 * -!* * -!* This subroutine initializes the fields for the simulations. * -!* The one argument passed to initialize, Time, is set to the * -!* current time of the simulation. The fields which are initialized * -!* here are: * -!* u - Zonal velocity in m s-1. * -!* v - Meridional velocity in m s-1. * -!* h - Layer thickness in m. (Must be positive.) * -!* D - Basin depth in m. (Must be positive.) * -!* f - The Coriolis parameter, in s-1. * -!* g - The reduced gravity at each interface, in m s-2. * -!* Rlay - Layer potential density (coordinate variable) in kg m-3. * -!* If TEMPERATURE is defined: * -!* T - Temperature in C. * -!* S - Salinity in psu. * -!* If BULKMIXEDLAYER is defined: * -!* Rml - Mixed layer and buffer layer potential densities in * -!* units of kg m-3. * -!* If SPONGE is defined: * -!* A series of subroutine calls are made to set up the damping * -!* rates and reference profiles for all variables that are damped * -!* in the sponge. * -!* Any user provided tracer code is also first linked through this * -!* subroutine. * -!* * -!* Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set * -!* in MOM_surface_forcing.F90. * -!* * -!* These variables are all set in the set of subroutines (in this * -!* file) USER_initialize_bottom_depth, USER_initialize_thickness, * -!* USER_initialize_velocity, USER_initialize_temperature_salinity, * -!* USER_initialize_mixed_layer_density, USER_initialize_sponges, * -!* USER_set_coord, and USER_set_ref_profile. * -!* * -!* The names of these subroutines should be self-explanatory. They * -!* start with "USER_" to indicate that they will likely have to be * -!* modified for each simulation to set the initial conditions and * -!* boundary conditions. Most of these take two arguments: an integer * -!* argument specifying whether the fields are to be calculated * -!* internally or read from a NetCDF file; and a string giving the * -!* path to that file. If the field is initialized internally, the * -!* path is ignored. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h.* -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q, f * -!* j+1 > o > o > At ^: v, tauy * -!* j x ^ x ^ x At >: u, taux * -!* j > o > o > At o: h, D, buoy, tr, T, S, Rml, ustar * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - ! use MOM_domains, only : sum_across_PEs 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_time_manager, only : time_type, set_time, time_type_to_real - -use mpp_mod, only : mpp_pe, mpp_sync ! use MOM_io, only : close_file, fieldtype, file_exists ! use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE -! use MOM_io, only : write_field, slasher, vardesc +! use MOM_io, only : write_field, slasher implicit none ; private #include @@ -94,13 +32,24 @@ module user_shelf_init contains +!> This subroutine sets up the initial mass and area covered by the ice shelf, based on user-provided code. subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, param_file, new_sim) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf, area_shelf_h, hmask, h_shelf - type(user_ice_shelf_CS), pointer :: CS - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - logical :: new_sim + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: mass_shelf !< The ice shelf mass per unit area averaged + !! over the full ocean cell, in kg m-2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + logical, intent(in) :: new_sim !< If true, this is a new run; otherwise it is + !! being started from a restart file. ! Arguments: mass_shelf - The mass per unit area averaged over the full ocean ! cell, in kg m-2. (Intent out) @@ -111,7 +60,6 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, ! model parameter values. -! just check for cvs ! This subroutine sets up the initial mass and area covered by the ice shelf. real :: Rho_ocean ! The ocean's typical density, in kg m-3. real :: max_draft ! The maximum ocean draft of the ice shelf, in m. @@ -149,13 +97,19 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, call USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, set_time(0,0), new_sim) - end subroutine USER_initialize_shelf_mass +!> This subroutine updates the ice shelf thickness, as specified by user-provided code. subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, param_file) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: area_shelf_h, hmask, h_shelf - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: h_shelf !< The ice shelf thickness, in m. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(out) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! This subroutine initializes the ice shelf thickness. Currently it does so ! calling USER_initialize_shelf_mass, but this can be revised as needed. @@ -166,12 +120,22 @@ subroutine USER_init_ice_thickness(h_shelf, area_shelf_h, hmask, G, param_file) end subroutine USER_init_ice_thickness +!> This subroutine updates the ice shelf mass, as specified by user-provided code. subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, CS, Time, new_sim) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: mass_shelf, area_shelf_h, hmask, h_shelf - type(user_ice_shelf_CS), pointer :: CS - type(time_type), intent(in) :: Time - logical, intent(in) :: new_sim + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: mass_shelf !< The ice shelf mass per unit area averaged + !! over the full ocean cell, in kg m-2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: area_shelf_h !< The area per cell covered by the ice shelf, in m2. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< The ice shelf thickness, in 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 + type(user_ice_shelf_CS), pointer :: CS !< A pointer to the user ice shelf control structure + type(time_type), intent(in) :: Time !< The current model time + logical, intent(in) :: new_sim !< If true, this the start of a new run. ! Arguments: mass_shelf - The mass per unit area averaged over the full ocean ! cell, in kg m-2. (Intent out) @@ -190,17 +154,17 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C c1 = 0.0 ; if (CS%shelf_slope_scale > 0.0) c1 = 1.0 / CS%shelf_slope_scale - do j=G%jsd,G%jed ; + do j=G%jsd,G%jed - if (((j+G%jdg_offset) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+G%jdg_offset) .ge. G%domain%njhalo+1)) then + if (((j+G%jdg_offset) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+G%jdg_offset) >= G%domain%njhalo+1)) then do i=G%isc,G%iec ! if (((i+G%idg_offset) <= G%domain%niglobal+G%domain%nihalo) .AND. & ! ((i+G%idg_offset) >= G%domain%nihalo+1)) then - if ((j.ge.G%jsc) .and. (j.le.G%jec)) then + if ((j >= G%jsc) .and. (j <= G%jec)) then if (new_sim) then ; if (G%geoLonCu(i-1,j) >= edge_pos) then ! Everything past the edge is open ocean. @@ -232,7 +196,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C endif ; endif ; endif - if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then + if ((i+G%idg_offset) == G%domain%nihalo+1) then hmask(i-1,j) = 3.0 endif @@ -240,6 +204,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C end subroutine USER_update_shelf_mass +!> This subroutine writes out the user ice shelf code version number to the model log. subroutine write_user_log(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 7aff08540a..0275bfc205 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -241,7 +241,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF) call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth, & "The (diagnosed) maximum depth of the ocean.", units="m") endif - if (trim(config) .ne. "DOME") then + if (trim(config) /= "DOME") then call limit_topography(D, G, PF, max_depth) endif diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 917e1b60ca..78d2a3fb8c 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -70,16 +70,27 @@ module MOM_grid_initialize public set_grid_metrics, initialize_masks, Adcroft_reciprocal type, public :: GPS ; private - real :: len_lon - real :: len_lat - real :: west_lon - real :: south_lat - real :: Rad_Earth - real :: Lat_enhance_factor - real :: Lat_eq_enhance - logical :: isotropic - logical :: equator_reference - integer :: niglobal, njglobal ! Duplicates of niglobal and njglobal from MOM_dom + real :: len_lon !< The longitudinal or x-direction length of the domain. + real :: len_lat !< The latitudinal or y-direction length of the domain. + real :: west_lon !< The western longitude of the domain or the equivalent + !! starting value for the x-axis. + real :: south_lat !< The southern latitude of the domain or the equivalent + !! starting value for the y-axis. + real :: Rad_Earth !< The radius of the Earth, in m. + real :: Lat_enhance_factor !< The amount by which the meridional resolution + !! is enhanced within LAT_EQ_ENHANCE of the equator. + real :: Lat_eq_enhance !< The latitude range to the north and south of the equator + !! over which the resolution is enhanced, in degrees. + logical :: isotropic !< If true, an isotropic grid on a sphere (also known as a Mercator grid) + !! is used. With an isotropic grid, the meridional extent of the domain + !! (LENLAT), the zonal extent (LENLON), and the number of grid points in each + !! direction are _not_ independent. In MOM the meridional extent is determined + !! to fit the zonal extent and the number of grid points, while grid is + !! perfectly isotropic. + logical :: equator_reference !< If true, the grid is defined to have the equator at the + !! nearest q- or h- grid point to (-LOWLAT*NJGLOBAL/LENLAT). + integer :: niglobal !< The number of i-points in the global grid computational domain + integer :: njglobal !< The number of j-points in the global grid computational domain end type GPS contains @@ -119,7 +130,8 @@ subroutine set_grid_metrics(G, param_file) " \t mercator - use a Mercator spherical grid.", & fail_if_missing=.true.) call get_param(param_file, "MOM_grid_init", "DEBUG", debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) ! These are defaults that may be changed in the next select block. G%x_axis_units = "degrees_east" ; G%y_axis_units = "degrees_north" @@ -277,7 +289,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) global_indices(3) = 1+SGdom%njhalo global_indices(4) = SGdom%njglobal+SGdom%njhalo exni(:) = 2*exni(:) ; exnj(:) = 2*exnj(:) - if(ASSOCIATED(G%domain%maskmap)) then + if (associated(G%domain%maskmap)) then call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & @@ -476,7 +488,7 @@ subroutine set_grid_metrics_cartesian(G, param_file) call callTree_enter("set_grid_metrics_cartesian(), MOM_grid_initialize.F90") - PI = 4.0*atan(1.0) ; + PI = 4.0*atan(1.0) call get_param(param_file, mdl, "AXIS_UNITS", units_temp, & "The units for the Cartesian axes. Valid entries are: \n"//& @@ -537,7 +549,7 @@ subroutine set_grid_metrics_cartesian(G, param_file) if (units_temp(1:1) == 'k') then ! Axes are measured in km. dx_everywhere = 1000.0 * G%len_lon / (REAL(niglobal)) dy_everywhere = 1000.0 * G%len_lat / (REAL(njglobal)) - else if (units_temp(1:1) == 'm') then ! Axes are measured in m. + elseif (units_temp(1:1) == 'm') then ! Axes are measured in m. dx_everywhere = G%len_lon / (REAL(niglobal)) dy_everywhere = G%len_lat / (REAL(njglobal)) else ! Axes are measured in degrees of latitude and longitude. @@ -678,7 +690,7 @@ subroutine set_grid_metrics_spherical(G, param_file) ! G%dxBu(I,J) = G%Rad_Earth * dLon*PI_180 * COS( G%geoLatBu(I,J)*PI_180 ) G%dyBu(I,J) = G%Rad_Earth * dLat*PI_180 G%areaBu(I,J) = G%dxBu(I,J) * G%dyBu(I,J) - enddo; enddo + enddo ; enddo do J=JsdB,JedB ; do i=isd,ied G%geoLonCv(i,J) = grid_LonT(i) @@ -689,7 +701,7 @@ subroutine set_grid_metrics_spherical(G, param_file) G%dxCv(i,J) = G%Rad_Earth * COS( G%geoLatCv(i,J)*PI_180 ) * dL_di ! G%dxCv(i,J) = G%Rad_Earth * (dLon*PI_180) * COS( G%geoLatCv(i,J)*PI_180 ) G%dyCv(i,J) = G%Rad_Earth * dLat*PI_180 - enddo; enddo + enddo ; enddo do j=jsd,jed ; do I=IsdB,IedB G%geoLonCu(I,j) = grid_lonB(I) @@ -700,7 +712,7 @@ subroutine set_grid_metrics_spherical(G, param_file) G%dxCu(I,j) = G%Rad_Earth * COS( G%geoLatCu(I,j)*PI_180 ) * dL_di ! G%dxCu(I,j) = G%Rad_Earth * dLon*PI_180 * COS( latitude ) G%dyCu(I,j) = G%Rad_Earth * dLat*PI_180 - enddo; enddo + enddo ; enddo do j=jsd,jed ; do i=isd,ied G%geoLonT(i,j) = grid_LonT(i) @@ -716,7 +728,7 @@ subroutine set_grid_metrics_spherical(G, param_file) ! dL_di = G%geoLatCv(i,max(jsd,J-1))*PI_180 ! In radians ! G%areaT(i,j) = Rad_Earth**2*dLon*dLat*ABS(SIN(latitude)-SIN(dL_di)) G%areaT(i,j) = G%dxT(i,j) * G%dyT(i,j) - enddo; enddo + enddo ; enddo call callTree_leave("set_grid_metrics_spherical()") end subroutine set_grid_metrics_spherical @@ -965,9 +977,11 @@ subroutine set_grid_metrics_mercator(G, param_file) end subroutine set_grid_metrics_mercator +!> This function returns the grid spacing in the logical x direction. function ds_di(x, y, GP) - real, intent(in) :: x, y - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_di ! This function returns the grid spacing in the logical x direction. ! Arguments: x - The latitude in question. @@ -978,9 +992,11 @@ function ds_di(x, y, GP) ! dy_di(x,y,GP)*dy_di(x,y,GP)) end function ds_di +!> This function returns the grid spacing in the logical y direction. function ds_dj(x, y, GP) - real, intent(in) :: x, y - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_dj ! This function returns the grid spacing in the logical y direction. ! Arguments: x - The latitude in question. @@ -992,13 +1008,18 @@ function ds_dj(x, y, GP) end function ds_dj +!> This function returns the contribution from the line integral along one of the four sides of a +!! cell face to the area of a cell, assuming that the sides follow a linear path in latitude and +!! longitude (i.e., on a Mercator grid). function dL(x1, x2, y1, y2) - real, intent(in) :: x1, x2, y1, y2 + real, intent(in) :: x1 !< Segment starting longitude, in degrees E. + real, intent(in) :: x2 !< Segment ending longitude, in degrees E. + real, intent(in) :: y1 !< Segment ending latitude, in degrees N. + real, intent(in) :: y2 !< Segment ending latitude, in degrees N. real :: dL -! This subroutine calculates the contribution from the line integral -! along one of the four sides of a cell face to the area of a cell, -! assuming that the sides follow a linear path in latitude and long- -! itude (i.e., on a Mercator grid). +! This subroutine calculates the contribution from the line integral along one +! of the four sides of a cell face to the area of a cell, assuming that the +! sides follow a linear path in latitude and longitude (i.e., on a Mercator grid). ! Argumnts: x1 - Segment starting longitude. ! (in) x2 - Segment ending longitude. ! (in) y1 - Segment ending latitude. @@ -1016,17 +1037,25 @@ function dL(x1, x2, y1, y2) end function dL +!> This subroutine finds and returns the value of y at which the monotonically increasing +!! function fn takes the value fnval, also returning in ittmax the number of iterations of +!! Newton's method that were used to polish the root. function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) - real :: find_root - real, external :: fn, dy_df - type(GPS), intent(in) :: GP - real, intent(in) :: fnval, y1, ymin, ymax - integer, intent(out) :: ittmax - real :: y, y_next + real :: find_root !< The value of y where fn(y) = fnval that will be returned + real, external :: fn !< The external function whose root is being sought + real, external :: dy_df !< The inverse of the derivative of that function + type(GPS), intent(in) :: GP !< A structure of grid parameters + real, intent(in) :: fnval !< The value of fn being sought + real, intent(in) :: y1 !< A first guess for y + real, intent(in) :: ymin !< The minimum permitted value of y + real, intent(in) :: ymax !< The maximum permitted value of y + integer, intent(out) :: ittmax !< The number of iterations used to polish the root + ! This subroutine finds and returns the value of y at which the ! monotonically increasing function fn takes the value fnval, also returning ! in ittmax the number of iterations of Newton's method that were ! used to polish the root. + real :: y, y_next real :: ybot, ytop, fnbot, fntop integer :: itt character(len=256) :: warnmesg @@ -1125,21 +1154,24 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) find_root = y end function find_root +!> This function calculates and returns the value of dx/di, where x is the +!! longitude in Radians, and i is the integral north-south grid index. function dx_di(x, GP) - real, intent(in) :: x - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: dx_di ! This subroutine calculates and returns the value of dx/di, where -! x is the longitude in Radians, and i is the integral north-south -! grid index. +! x is the longitude in Radians, and i is the integral north-south grid index. dx_di = (GP%len_lon * 4.0*atan(1.0)) / (180.0 * GP%niglobal) end function dx_di +!> This function calculates and returns the integral of the inverse +!! of dx/di to the point x, in radians. function Int_di_dx(x, GP) - real, intent(in) :: x - type(GPS), intent(in) :: GP + real, intent(in) :: x !< The longitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: Int_di_dx ! This subroutine calculates and returns the integral of the inverse ! of dx/di to the point x, in radians. @@ -1148,9 +1180,11 @@ function Int_di_dx(x, GP) end function Int_di_dx +!> This subroutine calculates and returns the value of dy/dj, where y is the +!! latitude in Radians, and j is the integral north-south grid index. function dy_dj(y, GP) - real, intent(in) :: y - type(GPS), intent(in) :: GP + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: dy_dj ! This subroutine calculates and returns the value of dy/dj, where ! y is the latitude in Radians, and j is the integral north-south @@ -1177,9 +1211,11 @@ function dy_dj(y, GP) end function dy_dj +!> This subroutine calculates and returns the integral of the inverse +!! of dy/dj to the point y, in radians. function Int_dj_dy(y, GP) - real, intent(in) :: y - type(GPS), intent(in) :: GP + real, intent(in) :: y !< The latitude in question + type(GPS), intent(in) :: GP !< A structure of grid parameters real :: Int_dj_dy ! This subroutine calculates and returns the integral of the inverse ! of dy/dj to the point y, in radians. @@ -1206,7 +1242,7 @@ function Int_dj_dy(y, GP) if (y >= y_eq_enhance) then r = r + I_C0*0.5*(GP%lat_enhance_factor - 1.0)*y_eq_enhance - else if (y <= -y_eq_enhance) then + elseif (y <= -y_eq_enhance) then r = r - I_C0*0.5*(GP%lat_enhance_factor - 1.0)*y_eq_enhance else r = r + I_C0*0.5*(GP%lat_enhance_factor - 1.0) * & @@ -1222,8 +1258,6 @@ end function Int_dj_dy ! ------------------------------------------------------------------------------ -! ------------------------------------------------------------------------------ - !> extrapolate_metric extrapolates missing metric data into all the halo regions. subroutine extrapolate_metric(var, jh, missing) real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos @@ -1339,14 +1373,12 @@ subroutine initialize_masks(G, PF) do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB G%dy_Cu(I,j) = G%mask2dCu(I,j) * G%dyCu(I,j) - G%dy_Cu_obc(I,j) = G%mask2dCu(I,j) * G%dyCu(I,j) G%areaCu(I,j) = G%dxCu(I,j) * G%dy_Cu(I,j) G%IareaCu(I,j) = G%mask2dCu(I,j) * Adcroft_reciprocal(G%areaCu(I,j)) enddo ; enddo do J=G%JsdB,G%JedB ; do i=G%isd,G%ied G%dx_Cv(i,J) = G%mask2dCv(i,J) * G%dxCv(i,J) - G%dx_Cv_obc(i,J) = G%mask2dCv(i,J) * G%dxCv(i,J) G%areaCv(i,J) = G%dyCv(i,J) * G%dx_Cv(i,J) G%IareaCv(i,J) = G%mask2dCv(i,J) * Adcroft_reciprocal(G%areaCv(i,J)) enddo ; enddo diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 8bb7a290ee..e818c33acd 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -265,7 +265,8 @@ subroutine apply_topography_edits_from_file(D, G, param_file) 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)/=0.) then - write(*,'(a,3i5,f8.2,a,f8.2,2i4)') 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j),'->',abs(new_depth(n)),i,j + write(*,'(a,3i5,f8.2,a,f8.2,2i4)') & + 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j),'->',abs(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: '//& @@ -445,13 +446,12 @@ end subroutine limit_topography ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- +!> This subroutine sets up the Coriolis parameter for a sphere subroutine set_rotation_planetary(f, G, param_file) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! Arguments: f - Coriolis parameter (vertical component) in s^-1 -! (in) G - grid type -! (in) param_file - parameter file type + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(out) :: f !< Coriolis parameter (vertical component) in s^-1 + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! This subroutine sets up the Coriolis parameter for a sphere character(len=30) :: mdl = "set_rotation_planetary" ! This subroutine's name. @@ -474,13 +474,12 @@ end subroutine set_rotation_planetary ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- +!> This subroutine sets up the Coriolis parameter for a beta-plane or f-plane subroutine set_rotation_beta_plane(f, G, param_file) - type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), intent(out) :: f - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! Arguments: f - Coriolis parameter (vertical component) in s^-1 -! (in) G - grid type -! (in) param_file - parameter file type + type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid + real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & + intent(out) :: f !< Coriolis parameter (vertical component) in s^-1 + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! This subroutine sets up the Coriolis parameter for a beta-plane integer :: I, J @@ -546,10 +545,13 @@ subroutine initialize_grid_rotation_angle(G, PF) end subroutine initialize_grid_rotation_angle ! ----------------------------------------------------------------------------- +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths based on a named set of sizes. subroutine reset_face_lengths_named(G, param_file, name) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=*), intent(in) :: name + character(len=*), intent(in) :: name !< The name for the set of face lengths. Only "global_1deg" + !! is currently implemented. ! This subroutine sets the open face lengths at selected points to restrict ! passages to their observed widths. @@ -671,6 +673,8 @@ end subroutine reset_face_lengths_named ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths from a arrays read from a file. subroutine reset_face_lengths_file(G, param_file) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -738,6 +742,8 @@ end subroutine reset_face_lengths_file ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- +!> This subroutine sets the open face lengths at selected points to restrict +!! passages to their observed widths from a list read from a file. subroutine reset_face_lengths_list(G, param_file) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -915,7 +921,8 @@ subroutine reset_face_lengths_list(G, param_file) write(*,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCu=0 at ",lat,lon," (",& u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") so grid metric is unmodified." else - write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& + write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & + "read_face_lengths_list : Modifying dy_Cu gridpoint at ",lat,lon," (",& u_lat(1,npt), u_lat(2,npt), u_lon(1,npt), u_lon(2,npt),") to ",G%dy_Cu(I,j),"m" endif endif @@ -943,7 +950,8 @@ subroutine reset_face_lengths_list(G, param_file) write(*,'(A,2F8.2,A,4F8.2,A)') "read_face_lengths_list : G%mask2dCv=0 at ",lat,lon," (",& v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") so grid metric is unmodified." else - write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& + write(*,'(A,2F8.2,A,4F8.2,A5,F9.2,A1)') & + "read_face_lengths_list : Modifying dx_Cv gridpoint at ",lat,lon," (",& v_lat(1,npt), v_lat(2,npt), v_lon(1,npt), v_lon(2,npt),") to ",G%dx_Cv(I,j),"m" endif endif @@ -965,11 +973,12 @@ end subroutine reset_face_lengths_list ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- +!> This subroutine reads and counts the non-blank lines in the face length list file, after removing comments. subroutine read_face_length_list(iounit, filename, num_lines, lines) - integer, intent(in) :: iounit - character(len=*), intent(in) :: filename - integer, intent(out) :: num_lines - character(len=120), dimension(:), pointer :: lines + integer, intent(in) :: iounit !< An open I/O unit number for the file + character(len=*), intent(in) :: filename !< The name of the face-length file to read + integer, intent(out) :: num_lines !< The number of non-blank lines in the file + character(len=120), dimension(:), pointer :: lines !< The non-blank lines, after removing comments ! This subroutine reads and counts the non-blank lines in the face length ! list file, after removing comments. @@ -1178,9 +1187,9 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) call create_file(unit, trim(filepath), vars, nFlds_used, fields, & file_threading, dG=G) - do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLatBu(I,J); enddo; enddo + do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLatBu(I,J); enddo ; enddo call write_field(unit, fields(1), G%Domain%mpp_domain, out_q) - do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLonBu(I,J); enddo; enddo + do J=Jsq,Jeq; do I=Isq,Ieq; out_q(I,J) = G%geoLonBu(I,J); enddo ; enddo call write_field(unit, fields(2), G%Domain%mpp_domain, out_q) call write_field(unit, fields(3), G%Domain%mpp_domain, G%geoLatT) call write_field(unit, fields(4), G%Domain%mpp_domain, G%geoLonT) @@ -1201,7 +1210,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, geom_file) do J=Jsq,Jeq ; do i=is,ie ; out_v(i,J) = G%dyCv(i,J) ; enddo ; enddo call write_field(unit, fields(10), G%Domain%mpp_domain, out_v) - do j=js,je ; do i=is,ie ; out_h(i,j) = G%dxT(i,j); enddo; enddo + do j=js,je ; do i=is,ie ; out_h(i,j) = G%dxT(i,j); enddo ; enddo call write_field(unit, fields(11), G%Domain%mpp_domain, out_h) do j=js,je ; do i=is,ie ; out_h(i,j) = G%dyT(i,j) ; enddo ; enddo call write_field(unit, fields(12), G%Domain%mpp_domain, out_h) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 858713002b..491c806a6b 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -17,10 +17,9 @@ module MOM_state_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_interface_heights, only : find_eta -use MOM_io, only : close_file, fieldtype, file_exists -use MOM_io, only : open_file, MOM_read_data, MOM_read_vector, read_axis_data -use MOM_io, only : slasher, vardesc, write_field -use MOM_io, only : EAST_FACE, NORTH_FACE , SINGLE_FILE, MULTIPLE +use MOM_io, only : file_exists +use MOM_io, only : MOM_read_data, MOM_read_vector +use MOM_io, only : slasher use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : open_boundary_query @@ -94,6 +93,7 @@ module MOM_state_initialization 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_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_horizontal_regridding, only : horiz_interp_and_extrap_tracer @@ -176,6 +176,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + real :: dt + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -194,7 +196,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "The directory in which input files are found.", default=".") inputdir = slasher(inputdir) - use_temperature = ASSOCIATED(tv%T) + use_temperature = associated(tv%T) useALE = associated(ALE_CSp) use_EOS = associated(tv%eqn_of_state) use_OBC = associated(OBC) @@ -266,8 +268,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & " \t USER - call a user modified routine.", & fail_if_missing=new_sim, do_not_log=just_read) select case (trim(config)) - case ("file"); call initialize_thickness_from_file(h, G, GV, PF, .false., just_read_params=just_read) - case ("thickness_file"); call initialize_thickness_from_file(h, G, GV, PF, .true., just_read_params=just_read) + case ("file") + call initialize_thickness_from_file(h, G, GV, PF, .false., just_read_params=just_read) + case ("thickness_file") + call initialize_thickness_from_file(h, G, GV, PF, .true., just_read_params=just_read) case ("coord") if (new_sim .and. useALE) then call ALE_initThicknessToCoord( ALE_CSp, G, GV, h ) @@ -465,8 +469,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, PF, dirs, & "an initial grid that is consistent with the initial conditions.", & default=1, do_not_log=just_read) - if (new_sim) & - call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, h, u, v) + call get_param(PF, mdl, "DT", dt, "Timestep", fail_if_missing=.true.) + + call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, tracer_Reg, & + dt=dt, initial=.true.) endif endif ! This is the end of the block of code that might have initialized fields @@ -610,19 +616,11 @@ subroutine initialize_thickness_from_file(h, G, GV, param_file, file_has_thickne logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) file_has_thickness - If true, this file contains thicknesses; -! otherwise it contains interface heights. - ! This subroutine reads the layer thicknesses from file. real :: eta(SZI_(G),SZJ_(G),SZK_(G)+1) integer :: inconsistent = 0 logical :: correct_thickness - logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate + logical :: just_read ! If true, just read parameters but set nothing. 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 @@ -706,8 +704,8 @@ end subroutine initialize_thickness_from_file subroutine adjustEtaToFitBathymetry(G, GV, eta, h) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)+1), intent(inout) :: eta !< Interface heights, in m - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(inout) :: h !< Layer thicknesses, in H + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: eta !< Interface heights, in m + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thicknesses, in H ! Local variables integer :: i, j, k, is, ie, js, je, nz, contractions, dilations real, parameter :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria (m) @@ -786,19 +784,13 @@ subroutine initialize_thickness_uniform(h, G, GV, param_file, just_read_params) logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. -! Arguments: h - The thickness that is being initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. - ! This subroutine initializes the layer thicknesses to be uniform. character(len=40) :: mdl = "initialize_thickness_uniform" ! This subroutine's name. real :: e0(SZK_(G)+1) ! The resting interface heights, in m, usually ! ! negative because it is positive upward. ! real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! ! positive upward, in m. ! - logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate + logical :: just_read ! If true, just read parameters but set nothing. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -861,7 +853,7 @@ subroutine initialize_thickness_list(h, G, GV, param_file, just_read_params) ! negative because it is positive upward. ! real :: eta1D(SZK_(G)+1)! Interface height relative to the sea surface ! ! positive upward, in m. ! - logical :: just_read ! If true, just read parameters but set nothing. character(len=20) :: verticalCoordinate + logical :: just_read ! If true, just read parameters but set nothing. character(len=200) :: filename, eta_file, inputdir ! Strings for file/path character(len=72) :: eta_var integer :: i, j, k, is, ie, js, je, nz @@ -934,7 +926,7 @@ end subroutine initialize_thickness_search subroutine convert_thickness(h, G, GV, tv) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: h !< Input eometric layer thicknesses (in H units), !! being converted to layer pressure !! thicknesses (also in H units). @@ -1013,7 +1005,7 @@ end subroutine convert_thickness subroutine depress_surface(h, G, GV, param_file, tv, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(inout) :: h !< Layer thicknesses, in H (usually m or kg m-2) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables @@ -1116,8 +1108,8 @@ subroutine trim_for_ice(PF, G, GV, ALE_CSp, tv, h, just_read_params) ! Local variables character(len=200) :: mdl = "trim_for_ice" real, dimension(SZI_(G),SZJ_(G)) :: p_surf ! Imposed pressure on ocean at surface (Pa) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_t, S_b, T_t, T_b ! Top and bottom edge values for reconstructions - ! of salinity and temperature within each layer. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_t, S_b ! Top and bottom edge values for reconstructions + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_t, T_b ! of salinity and temperature within each layer. character(len=200) :: inputdir, filename, p_surf_file, p_surf_var ! Strings for file/path real :: scale_factor, min_thickness integer :: i, j, k @@ -1159,11 +1151,7 @@ subroutine trim_for_ice(PF, G, GV, ALE_CSp, tv, h, just_read_params) ! Find edge values of T and S used in reconstructions if ( associated(ALE_CSp) ) then ! This should only be associated if we are in ALE mode -! if ( PRScheme == PRESSURE_RECONSTRUCTION_PLM ) then - call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h) -! elseif ( PRScheme == PRESSURE_RECONSTRUCTION_PPM ) then -! call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h) -! endif + call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, .true.) else ! call MOM_error(FATAL, "trim_for_ice: Does not work without ALE mode") do k=1,G%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -1265,8 +1253,10 @@ end subroutine cut_off_column_top ! ----------------------------------------------------------------------------- subroutine initialize_velocity_from_file(u, v, G, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to !! parse for modelparameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -1309,8 +1299,10 @@ end subroutine initialize_velocity_from_file ! ----------------------------------------------------------------------------- subroutine initialize_velocity_zero(u, v, G, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to !! parse for modelparameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -1347,8 +1339,10 @@ end subroutine initialize_velocity_zero ! ----------------------------------------------------------------------------- subroutine initialize_velocity_uniform(u, v, G, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to !! parse for modelparameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -1390,8 +1384,10 @@ end subroutine initialize_velocity_uniform ! ----------------------------------------------------------------------------- subroutine initialize_velocity_circular(u, v, G, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)), intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 - real, dimension(SZI_(G),SZJB_(G), SZK_(G)), intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(out) :: u !< The zonal velocity that is being initialized, in m s-1 + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(out) :: v !< The meridional velocity that is being initialized, in m s-1 type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to !! parse for modelparameter values. logical, optional, intent(in) :: just_read_params !< If present and true, this call will @@ -1452,8 +1448,8 @@ end subroutine initialize_velocity_circular ! ----------------------------------------------------------------------------- subroutine initialize_temp_salt_from_file(T, S, G, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T !< The potential temperature that is being initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: S !< The salinity that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being initialized. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. @@ -1517,7 +1513,8 @@ end subroutine initialize_temp_salt_from_file ! ----------------------------------------------------------------------------- subroutine initialize_temp_salt_from_profile(T, S, G, param_file, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T, S + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being initialized. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters logical, optional, intent(in) :: just_read_params !< If present and true, this call will !! only read parameters without changing h. @@ -1572,11 +1569,8 @@ end subroutine initialize_temp_salt_from_profile subroutine initialize_temp_salt_fit(T, S, G, GV, param_file, eqn_of_state, P_Ref, just_read_params) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & - intent(out) :: T !< The potential temperature that is being - !! initialized. - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), & - intent(out) :: S !< The salinity that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being initialized. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(EOS_type), pointer :: eqn_of_state !< Integer that selects the equatio of state. @@ -1670,20 +1664,21 @@ end subroutine initialize_temp_salt_fit ! ----------------------------------------------------------------------------- subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G), SZK_(G)), intent(out) :: T, S - type(param_file_type), intent(in) :: param_file !< A structure to parse for - !! run-time parameters - logical, optional, intent(in) :: just_read_params !< If present and true, - !! this call will only read - !! parameters without - !! changing h. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: T !< The potential temperature that is being initialized. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: S !< The salinity that is being initialized. + type(param_file_type), intent(in) :: param_file !< A structure to parse for + !! run-time parameters + logical, optional, intent(in) :: just_read_params !< If present and true, + !! this call will only read + !! parameters without + !! changing h. ! This subroutine initializes linear profiles for T and S according to ! reference surface layer salinity and temperature and a specified range. ! Note that the linear distribution is set up with respect to the layer ! number, not the physical position). - integer :: k; + integer :: k real :: delta_S, delta_T real :: S_top, T_top ! Reference salinity and temerature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical @@ -1710,24 +1705,24 @@ subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) if (just_read) return ! All run-time parameters have been read, so return. ! ! Prescribe salinity -! delta_S = S_range / ( G%ke - 1.0 ); -! S(:,:,1) = S_top; +! delta_S = S_range / ( G%ke - 1.0 ) +! S(:,:,1) = S_top ! do k = 2,G%ke -! S(:,:,k) = S(:,:,k-1) + delta_S; -! end do +! S(:,:,k) = S(:,:,k-1) + delta_S +! enddo do k = 1,G%ke S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(G%ke)) T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(G%ke)) - end do + enddo ! ! Prescribe temperature -! delta_T = T_range / ( G%ke - 1.0 ); -! T(:,:,1) = T_top; +! delta_T = T_range / ( G%ke - 1.0 ) +! T(:,:,1) = T_top ! do k = 2,G%ke -! T(:,:,k) = T(:,:,k-1) + delta_T; -! end do -! delta = 1; -! T(:,:,G%ke/2 - (delta-1):G%ke/2 + delta) = 1.0; +! T(:,:,k) = T(:,:,k-1) + delta_T +! enddo +! delta = 1 +! T(:,:,G%ke/2 - (delta-1):G%ke/2 + delta) = 1.0 call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_linear @@ -1853,7 +1848,7 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, ! apply the sponges, along with the interface heights. ! call initialize_sponge(Idamp, eta, G, param_file, CSp) deallocate(eta) - else if (.not. new_sponges) then ! ALE mode + elseif (.not. new_sponges) then ! ALE mode call field_size(filename,eta_var,siz,no_domain=.true.) if (siz(1) /= G%ieg-G%isg+1 .or. siz(2) /= G%jeg-G%jsg+1) & @@ -1877,7 +1872,7 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, enddo ; enddo ; enddo do k=1,nz; do j=js,je ; do i=is,ie h(i,j,k) = eta(i,j,k)-eta(i,j,k+1) - enddo ; enddo; enddo + enddo ; enddo ; enddo call initialize_ALE_sponge(Idamp, G, param_file, ALE_CSp, h, nz_data) deallocate(eta) deallocate(h) @@ -1915,7 +1910,7 @@ subroutine initialize_sponges_file(G, GV, use_temperature, tv, param_file, CSp, call set_up_sponge_field(tmp, tv%T, G, nz, CSp) call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain) call set_up_sponge_field(tmp, tv%S, G, nz, CSp) - else if (use_temperature) then + elseif (use_temperature) then call set_up_ALE_sponge_field(filename, potemp_var, Time, G, tv%T, ALE_CSp) call set_up_ALE_sponge_field(filename, salin_var, Time, G, tv%S, ALE_CSp) endif @@ -2007,6 +2002,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) character(len=200) :: mesg, area_varname, ice_shelf_file type(EOS_type), pointer :: eos => NULL() + type(thermo_var_ptrs) :: tv_loc ! A temporary thermo_var container + type(verticalGrid_type) :: GV_loc ! A temporary vertical grid structure ! This include declares and sets the variable "version". #include "version_variable.h" @@ -2022,6 +2019,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) integer :: nkml, nkbl ! number of mixed and buffer layers integer :: kd, inconsistent + integer :: nkd ! number of levels to use for regridding input arrays real :: PI_180 ! for conversion from degrees to radians real, dimension(:,:), pointer :: shelf_area @@ -2052,9 +2050,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) ! Local variables for ALE remapping real, dimension(:), allocatable :: hTarget real, dimension(:,:), allocatable :: area_shelf_h - real, dimension(:,:), allocatable, target :: frac_shelf_h - real, dimension(:,:,:), allocatable :: tmpT1dIn, tmpS1dIn, tmp_mask_in + real, dimension(:,:), allocatable, target :: frac_shelf_h + real, dimension(:,:,:), allocatable, target :: tmpT1dIn, tmpS1dIn + real, dimension(:,:,:), allocatable :: tmp_mask_in real, dimension(:,:,:), allocatable :: h1 ! Thicknesses in H. + real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to regridding real :: zTopOfCell, zBottomOfCell type(regridding_CS) :: regridCS ! Regridding parameters and work arrays type(remapping_CS) :: remapCS ! Remapping parameters and work arrays @@ -2231,23 +2231,24 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) ! Now remap to model coordinates if (useALEremapping) then call cpu_clock_begin(id_clock_ALE) + nkd = max(GV%ke, kd) ! The regridding tools (grid generation) are coded to work on model arrays of the same ! vertical shape. We need to re-write the regridding if the model has fewer layers ! than the data. -AJA - if (kd>nz) call MOM_error(FATAL,"MOM_initialize_state, MOM_temp_salt_initialize_from_Z(): "//& - "Data has more levels than the model - this has not been coded yet!") + !if (kd>nz) call MOM_error(FATAL,"MOM_initialize_state, MOM_temp_salt_initialize_from_Z(): "//& + ! "Data has more levels than the model - this has not been coded yet!") ! Build the source grid and copy data onto model-shaped arrays with vanished layers - allocate( tmp_mask_in(isd:ied,jsd:jed,nz) ) ; tmp_mask_in(:,:,:) = 0. - allocate( h1(isd:ied,jsd:jed,nz) ) ; h1(:,:,:) = 0. - allocate( tmpT1dIn(isd:ied,jsd:jed,nz) ) ; tmpT1dIn(:,:,:) = 0. - allocate( tmpS1dIn(isd:ied,jsd:jed,nz) ) ; tmpS1dIn(:,:,:) = 0. + allocate( tmp_mask_in(isd:ied,jsd:jed,nkd) ) ; tmp_mask_in(:,:,:) = 0. + allocate( h1(isd:ied,jsd:jed,nkd) ) ; h1(:,:,:) = 0. + allocate( tmpT1dIn(isd:ied,jsd:jed,nkd) ) ; tmpT1dIn(:,:,:) = 0. + allocate( tmpS1dIn(isd:ied,jsd:jed,nkd) ) ; tmpS1dIn(:,:,:) = 0. do j = js, je ; do i = is, ie if (G%mask2dT(i,j)>0.) then - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 + zTopOfCell = 0. ; zBottomOfCell = 0. tmp_mask_in(i,j,1:kd) = mask_z(i,j,:) - do k = 1, nz + do k = 1, nkd if (tmp_mask_in(i,j,k)>0. .and. k<=kd) then - zBottomOfCell = -min( z_edges_in(k+1), G%bathyT(i,j) ) + zBottomOfCell = max( -z_edges_in(k+1), -G%bathyT(i,j) ) tmpT1dIn(i,j,k) = temp_z(i,j,k) tmpS1dIn(i,j,k) = salt_z(i,j,k) elseif (k>1) then @@ -2259,10 +2260,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) tmpS1dIn(i,j,k) = -99.9 endif h1(i,j,k) = GV%m_to_H * (zTopOfCell - zBottomOfCell) - if (h1(i,j,k)>0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - h1(i,j,kd) = h1(i,j,kd) + GV%m_to_H * ( zTopOfCell + G%bathyT(i,j) ) ! In case data is deeper than model + h1(i,j,kd) = h1(i,j,kd) + GV%m_to_H * max(0., zTopOfCell + G%bathyT(i,j) ) + ! The max here is in case the data data is shallower than model endif ! mask2dT enddo ; enddo deallocate( tmp_mask_in ) @@ -2300,24 +2301,23 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, G, GV, PF, just_read_params) call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false. ) ! Reconstruction parameters if (remap_general) then call set_regrid_params( regridCS, min_thickness=0. ) - h(:,:,:) = h1(:,:,:) ; tv%T(:,:,:) = tmpT1dIn(:,:,:) ; tv%S(:,:,:) = tmpS1dIn(:,:,:) - do j = js, je ; do i = is, ie - if (G%mask2dT(i,j)==0.) then ! Ensure there are no nonsense values on land - h(i,j,:) = 0. ; tv%T(i,j,:) = 0. ; tv%S(i,j,:) = 0. - endif - enddo ; enddo - call pass_var(h, G%Domain) ! Regridding might eventually use spatial information and - call pass_var(tv%T, G%Domain) ! thus needs to be up to date in the halo regions even though - call pass_var(tv%S, G%Domain) ! ALE_build_grid() only updates h on the computational domain. - + tv_loc = tv + tv_loc%T => tmpT1dIn + tv_loc%S => tmpS1dIn + 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 ALE_build_grid( G, GV, regridCS, remapCS, h, tv, .true., shelf_area) + call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, shelf_area ) else - call ALE_build_grid( G, GV, regridCS, remapCS, h, tv, .true. ) + call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface ) endif + deallocate( dz_interface ) endif - call ALE_remap_scalar( remapCS, G, GV, nz, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, old_remap=remap_old_alg ) - call ALE_remap_scalar( remapCS, G, GV, nz, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, old_remap=remap_old_alg ) + call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & + old_remap=remap_old_alg ) + call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpS1dIn, h, tv%S, all_cells=remap_full_column, & + old_remap=remap_old_alg ) deallocate( h1 ) deallocate( tmpT1dIn ) deallocate( tmpS1dIn ) @@ -2451,7 +2451,8 @@ subroutine MOM_state_init_tests(G, GV, tv) S_t(k) = 35.-(0./500.)*e(k) S(k) = 35.+(0./500.)*z(k) S_b(k) = 35.-(0./500.)*e(k+1) - call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -GV%Rho0*GV%g_Earth*z(k), rho(k), tv%eqn_of_state) + call calculate_density(0.5*(T_t(k)+T_b(k)), 0.5*(S_t(k)+S_b(k)), -GV%Rho0*GV%g_Earth*z(k), & + rho(k), tv%eqn_of_state) P_tot = P_tot + GV%g_Earth * rho(k) * h(k) enddo diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index b439a9decc..71156c27b8 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -14,9 +14,6 @@ module MOM_tracer_initialization_from_Z use MOM_file_parser, only : log_version use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell -use MOM_io, only : close_file, fieldtype, file_exists -use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE, MULTIPLE -use MOM_io, only : slasher, vardesc, write_field use MOM_string_functions, only : uppercase use MOM_time_manager, only : time_type, set_time use MOM_variables, only : thermo_var_ptrs @@ -41,29 +38,24 @@ module MOM_tracer_initialization_from_Z contains +!> MOM_initialize_tracer_from_Z initializes a tracer from a z-space data file. subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, & - src_var_unit_conversion, src_var_record, & - homogenize, useALEremapping, remappingScheme, src_var_gridspec ) + src_var_unit_conversion, src_var_record, homogenize, & + useALEremapping, remappingScheme, src_var_gridspec ) -! Arguments: -! (in) h - Layer thickness, in m. -! (inout) tr - pointer to array containing field to be initialized. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. - - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h !< Layer thickness, in m. - real, dimension(:,:,:), pointer, intent(inout) :: tr !< Pointer to array to be initialized - type(param_file_type), intent(in) :: PF !< parameter file - character(len=*), intent(in) :: src_file, src_var_nam !< source filename and variable name on disk - real, optional, intent(in) :: src_var_unit_conversion !< optional multiplicative unit conversion - integer, optional, intent(in) :: src_var_record !< record to read for multiple time-level files - logical, optional, intent(in) :: homogenize !< optionally homogenize to mean value - logical, optional, intent(in) :: useALEremapping !< to remap or not (optional) - character(len=*), optional, intent(in) :: remappingScheme !< remapping scheme to use. - character(len=*), optional, intent(in) :: src_var_gridspec ! Not implemented yet. + intent(in) :: h !< Layer thickness, in m. + real, dimension(:,:,:), pointer :: tr !< Pointer to array to be initialized + type(param_file_type), intent(in) :: PF !< parameter file + character(len=*), intent(in) :: src_file, src_var_nam !< source filename and variable name on disk + real, optional, intent(in) :: src_var_unit_conversion !< optional multiplicative unit conversion + integer, optional, intent(in) :: src_var_record !< record to read for multiple time-level files + logical, optional, intent(in) :: homogenize !< optionally homogenize to mean value + logical, optional, intent(in) :: useALEremapping !< to remap or not (optional) + character(len=*), optional, intent(in) :: remappingScheme !< remapping scheme to use. + character(len=*), optional, intent(in) :: src_var_gridspec ! Not implemented yet. real :: land_fill = 0.0 character(len=200) :: inputdir ! The directory where NetCDF input files are. @@ -207,16 +199,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, PF, src_file, src_var_nam, endif enddo ; enddo ; enddo - call callTree_leave(trim(mdl)//'()') call cpu_clock_end(id_clock_routine) - end subroutine MOM_initialize_tracer_from_Z - - - - end module MOM_tracer_initialization_from_Z diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 index c1ba6793b8..8d022d97cc 100644 --- a/src/initialization/midas_vertmap.F90 +++ b/src/initialization/midas_vertmap.F90 @@ -79,11 +79,11 @@ function wright_eos_2d(T,S,p) result(rho) real(kind=8) :: al0,lam,p0,I_denom integer :: i,k - a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; - b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; - b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; - c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; - c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; + a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 + b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 + b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 + c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 + c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 do k=1,size(T,2) do i=1,size(T,1) @@ -120,11 +120,11 @@ function alpha_wright_eos_2d(T,S,p) result(drho_dT) real(kind=8) :: al0,lam,p0,I_denom,I_denom2 integer :: i,k -a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; -b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; -b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; -c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; -c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; +a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 +b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 +b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 +c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 +c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 do k=1,size(T,2) do i=1,size(T,1) @@ -167,11 +167,11 @@ function beta_wright_eos_2d(T,S,p) result(drho_dS) real(kind=8) :: al0,lam,p0,I_denom,I_denom2 integer :: i,k -a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; -b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; -b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; -c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; -c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; +a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 +b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 +b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 +c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 +c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 do k=1,size(T,2) do i=1,size(T,1) @@ -227,8 +227,8 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, real, intent(in) :: land_fill real, dimension(size(tr_in,1),size(tr_in,2)), intent(in) :: wet real, dimension(size(tr_in,1),size(tr_in,2)), optional, intent(in) ::nlevs -logical, intent(in), optional :: debug -integer, intent(in), optional :: i_debug, j_debug +logical, optional, intent(in) :: debug +integer, optional, intent(in) :: i_debug, j_debug real, dimension(size(tr_in,1),size(tr_in,2),nlay) :: tr real, dimension(size(tr_in,3)) :: tr_1d @@ -262,7 +262,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, do j=1,ny i_loop: do i=1,nx - if (nlevs_data(i,j) .eq. 0 .or. wet(i,j) .eq. 0.) then + if (nlevs_data(i,j) == 0 .or. wet(i,j) == 0.) then tr(i,j,:) = land_fill cycle i_loop endif @@ -297,7 +297,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, if (debug_) then if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then + if (i == i_debug.and.j == j_debug) then print *,'0001 k,k_top,k_bot,sum(wt),sum(z2-z1) = ',k,k_top,k_bot,sum(wt),sum(z2-z1) endif endif @@ -321,7 +321,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, ! endif if (debug_) then if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then + if (i == i_debug.and.j == j_debug) then print *,'0002 k,k_top,k_bot,k_bot_prev,sl_tr = ',k,k_top,k_bot,k_bot_prev,sl_tr endif endif @@ -333,7 +333,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, if (debug_) then if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then + if (i == i_debug.and.j == j_debug) then print *,'0003 k,tr = ',k,tr(i,j,k) endif endif @@ -357,7 +357,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, if (debug_) then if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then + if (i == i_debug.and.j == j_debug) then print *,'0004 k,kz,nlevs,sl_tr,tr = ',k,kz,nlevs_data(i,j),sl_tr,tr(i,j,k) print *,'0005 k,kz,tr(kz),tr(kz-1),tr(kz+1) = ',k,kz,tr_1d(kz),tr_1d(kz-1),tr_1d(kz+1),z_edges(kz+2) endif @@ -371,7 +371,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, enddo ! k-loop do k=2,nlay ! simply fill vanished layers with adjacent value - if (e_1d(k)-e_1d(k+1) .le. epsln) tr(i,j,k)=tr(i,j,k-1) + if (e_1d(k)-e_1d(k+1) <= epsln) tr(i,j,k)=tr(i,j,k-1) enddo enddo i_loop @@ -397,7 +397,7 @@ function bisect_fast(a, x, lo, hi) result(bi_r) real, dimension(:,:), intent(in) :: a real, dimension(:), intent(in) :: x -integer, dimension(size(a,1)), intent(in), optional :: lo,hi +integer, dimension(size(a,1)), optional, intent(in) :: lo,hi integer, dimension(size(a,1),size(x,1)) :: bi_r integer :: mid,num_x,num_a,i @@ -408,7 +408,7 @@ function bisect_fast(a, x, lo, hi) result(bi_r) if (PRESENT(lo)) then where (lo>0) lo_=lo -end if +endif if (PRESENT(hi)) then where (hi>0) hi_=hi endif @@ -494,7 +494,7 @@ subroutine determine_temperature(temp,salt,R,p_ref,niter,land_fill,h,k_start,eos integer, intent(in) :: k_start real, intent(in) :: land_fill real, dimension(:,:,:), intent(in) :: h -type(eos_type), pointer, intent(in) :: eos +type(eos_type), pointer :: eos real(kind=8), dimension(size(temp,1),size(temp,3)) :: T,S,dT,dS,rho,hin real(kind=8), dimension(size(temp,1),size(temp,3)) :: drho_dT,drho_dS @@ -689,7 +689,8 @@ function find_limited_slope(val, e, k) result(slope) real, dimension(:), intent(in) :: val real, dimension(:), intent(in) :: e integer, intent(in) :: k -real :: slope,amx,bmx,amn,bmn,cmn,dmn +real :: slope +real :: amx,bmx,amn,bmn,cmn,dmn real :: d1, d2 @@ -719,8 +720,6 @@ function find_limited_slope(val, e, k) result(slope) end function find_limited_slope - - function find_interfaces(rho,zin,Rb,depth,nlevs,nkml,nkbl,hml,debug) result(zi) ! (in) rho : potential density in z-space (kg m-3) ! (in) zin : levels (m) @@ -731,15 +730,20 @@ function find_interfaces(rho,zin,Rb,depth,nlevs,nkml,nkbl,hml,debug) result(zi) ! (in) nkbl : number of buffer layer pieces ! (in) hml : mixed layer depth -real, dimension(:,:,:), intent(in) :: rho -real, dimension(size(rho,3)), intent(in) :: zin +real, dimension(:,:,:), & + intent(in) :: rho +real, dimension(size(rho,3)), & + intent(in) :: zin real, dimension(:), intent(in) :: Rb -real, dimension(size(rho,1),size(rho,2)), intent(in) :: depth -real, dimension(size(rho,1),size(rho,2)), optional, intent(in) ::nlevs -logical, optional, intent(in) :: debug +real, dimension(size(rho,1),size(rho,2)), & + intent(in) :: depth +real, dimension(size(rho,1),size(rho,2)), & + optional, intent(in) ::nlevs +logical, optional, intent(in) :: debug +integer, optional, intent(in) :: nkml +integer, optional, intent(in) :: nkbl +real, optional, intent(in) :: hml real, dimension(size(rho,1),size(rho,2),size(Rb,1)) :: zi -integer, intent(in), optional :: nkml, nkbl -real, intent(in), optional :: hml real, dimension(size(rho,1),size(rho,3)) :: rho_ real, dimension(size(rho,1)) :: depth_ @@ -758,8 +762,7 @@ function find_interfaces(rho,zin,Rb,depth,nlevs,nkml,nkbl,hml,debug) result(zi) nlay=size(Rb)-1 -zi=0.0 - +zi(:,:,:) = 0.0 if (PRESENT(debug)) debug_=debug @@ -789,7 +792,7 @@ function find_interfaces(rho,zin,Rb,depth,nlevs,nkml,nkbl,hml,debug) result(zi) if (dir == 1) then do k=2,nlevs_data(i,j)-1 if (rho_(i,k) - rho_(i,k-1) < 0.0 ) then - if (k.eq.2) then + if (k == 2) then rho_(i,k-1)=rho_(i,k)-epsln else drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) @@ -804,7 +807,7 @@ function find_interfaces(rho,zin,Rb,depth,nlevs,nkml,nkbl,hml,debug) result(zi) else do k=nlevs_data(i,j)-1,2,-1 if (rho_(i,k+1) - rho_(i,k) < 0.0) then - if (k .eq. nlevs_data(i,j)-1) then + if (k == nlevs_data(i,j)-1) then rho_(i,k+1)=rho_(i,k-1)+epsln else drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) @@ -919,7 +922,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) endif @@ -929,7 +932,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) do n=1,niter do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) Isum = 1.0/bsum res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& @@ -947,9 +950,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) zi(:,:)=mp(1:ni,1:nj) mp = fill_boundaries(zi,cyclic_x,tripolar_n) -end do - - +enddo return @@ -1010,6 +1011,4 @@ function fill_boundaries_real(m,cyclic_x,tripolar_n) result(mp) end function fill_boundaries_real - - end module midas_vertmap diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 new file mode 100644 index 0000000000..b71a2bacf4 --- /dev/null +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -0,0 +1,551 @@ +module MOM_oda_driver_mod +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! This is the top-level module for MOM6 ocean data assimilation. +! It can be used to gather an ensemble of ocean states +! before calling ensemble filter routines which calculate +! increments based on cross-ensemble co-variance. It can also +! be used to compare gridded model state variables to in-situ +! observations without applying DA incrementa. +! +! init_oda: Initialize the ODA module +! set_analysis_time : update time for performing next analysis +! set_prior: Store prior model state +! oda: call to filter +! get_posterior : returns posterior increments (or full state) for the current ensemble member +! +! Authors: Matthew.Harrison@noaa.gov +! Feiyu.Liu@noaa.gov and +! Tony.Rosati@noaa.gov +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use fms_mod, only : open_namelist_file, close_file, check_nml_error + use fms_mod, only : error_mesg, FATAL + use mpp_mod, only : stdout, stdlog, mpp_error, npes=>mpp_npes,pe=>mpp_pe + use mpp_mod, only : set_current_pelist => mpp_set_current_pelist + use mpp_mod, only : set_root_pe => mpp_set_root_pe + use mpp_mod, only : mpp_sync_self, mpp_sum, get_pelist=>mpp_get_current_pelist, mpp_root_pe + use mpp_mod, only : set_stack_size=>mpp_set_stack_size, broadcast=>mpp_broadcast + use mpp_io_mod, only : io_set_stack_size=>mpp_io_set_stack_size + use mpp_io_mod, only : MPP_SINGLE,MPP_MULTI + use mpp_domains_mod, only : domain2d, mpp_global_field + use mpp_domains_mod, only : mpp_get_compute_domain, mpp_get_data_domain + use mpp_domains_mod, only : mpp_redistribute, mpp_broadcast_domain + use mpp_domains_mod, only : set_domains_stack_size=>mpp_domains_set_stack_size + use diag_manager_mod, only : register_diag_field, diag_axis_init, send_data + use ensemble_manager_mod, only : get_ensemble_id, get_ensemble_size + use ensemble_manager_mod, only : get_ensemble_pelist, get_ensemble_filter_pelist + use time_manager_mod, only : time_type, decrement_time, increment_time + use time_manager_mod, only : get_date, get_time, operator(>=),operator(/=),operator(==),operator(<) + use constants_mod, only : radius, epsln + ! ODA Modules + use ocean_da_types_mod, only : grid_type, ocean_profile_type, ocean_control_struct + use ocean_da_core_mod, only : ocean_da_core_init, get_profiles + !use eakf_oda_mod, only : ensemble_filter + use write_ocean_obs_mod, only : open_profile_file + use write_ocean_obs_mod, only : write_profile,close_profile_file + use kdtree, only : kd_root !# JEDI + ! MOM Modules + use MOM_io, only : slasher, MOM_read_data + use MOM_diag_mediator, only : diag_ctrl, set_axes_info + use MOM_error_handler, only : FATAL, WARNING, MOM_error, is_root_pe + use MOM_get_input, only : get_MOM_input, directories + use MOM_variables, only : thermo_var_ptrs + use MOM_grid, only : ocean_grid_type, MOM_grid_init + use MOM_grid_initialize, only : set_grid_metrics + use MOM_hor_index, only : hor_index_type, hor_index_init + use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid + use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid + use MOM_fixed_initialization, only : MOM_initialize_fixed, MOM_initialize_topography + use MOM_coord_initialization, only : MOM_initialize_coord + use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit + use MOM_file_parser, only : read_param, get_param, param_file_type + use MOM_string_functions, only : lowercase + use MOM_ALE, only : ALE_CS, ALE_initThicknessToCoord, ALE_init, ALE_updateVerticalGridType + use MOM_domains, only : MOM_domains_init, MOM_domain_type, clone_MOM_domain + use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h + use MOM_regridding, only : regridding_CS, initialize_regridding + use MOM_regridding, only : regridding_main, set_regrid_params + + implicit none ; private + + public :: init_oda, oda_end, set_prior_tracer, get_posterior_tracer + public :: set_analysis_time, oda, save_obs_diff, apply_oda_tracer_increments + +#include + + type, public :: ODA_CS; private + type(ocean_control_struct), pointer :: Ocean_prior=> NULL() !< ensemble ocean prior states in DA space + type(ocean_control_struct), pointer :: Ocean_posterior=> NULL() !< ensemble ocean posterior states + !! or increments to prior in DA space + integer :: nk !< number of vertical layers used for DA + type(ocean_grid_type), pointer :: Grid => NULL() !< MOM6 grid type and decomposition for the DA + type(pointer_mpp_domain), pointer, dimension(:) :: domains => NULL() !< Pointer to mpp_domain objects + !! for ensemble members + type(verticalGrid_type), pointer :: GV => NULL() !< vertical grid for DA + type(domain2d), pointer :: mpp_domain => NULL() !< Pointer to a mpp domain object for DA + type(grid_type), pointer :: oda_grid !< local tracer grid + real, pointer, dimension(:,:,:) :: h => NULL() ! NULL() !< pointer to thermodynamic variables + integer :: ni, nj !< global grid size + logical :: reentrant_x !< grid is reentrant in the x direction + logical :: reentrant_y !< grid is reentrant in the y direction + logical :: tripolar_N !< grid is folded at its north edge + logical :: symmetric !< Values at C-grid locations are symmetric + integer :: assim_method !< Method: NO_ASSIM,EAKF_ASSIM or OI_ASSIM + integer :: ensemble_size !< Size of the ensemble + integer :: ensemble_id = 0 !< id of the current ensemble member + integer, pointer, dimension(:,:) :: ensemble_pelist !< PE list for ensemble members + integer, pointer, dimension(:) :: filter_pelist !< PE list for ensemble members + integer :: assim_frequency !< analysis interval in hours + ! Profiles local to the analysis domain + type(ocean_profile_type), pointer :: Profiles => NULL() !< pointer to linked list of all available profiles + type(ocean_profile_type), pointer :: CProfiles => NULL()!< pointer to linked list of current profiles + type(kd_root), pointer :: kdroot + type(ALE_CS), pointer :: ALE_CS=>NULL() !< ALE control structure for DA + logical :: use_ALE_algorithm !< true is using ALE remapping + type(regridding_CS) :: regridCS !< ALE control structure for regridding + type(remapping_CS) :: remapCS !< ALE control structure for remapping + type(time_type) :: Time !< Current Analysis time + type(diag_ctrl) :: diag_cs ! NULL() + end type pointer_mpp_domain + + + integer, parameter :: NO_ASSIM = 0, OI_ASSIM=1, EAKF_ASSIM=2 + +contains + +!V initialize First_guess (prior) and Analysis grid +!! information for all ensemble members +!! + subroutine init_oda(Time, G, GV, CS) + + type(time_type), intent(in) :: Time !< The current model time. + type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ODA_CS), pointer, intent(inout) :: CS + + ! Local variables + type(thermo_var_ptrs) :: tv_dummy + type(dyn_horgrid_type), pointer :: dG=> NULL() + type(hor_index_type), pointer :: HI=> NULL() + 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 :: stdout_unit + character(len=32) :: assim_method + integer :: npes_pm, ens_info(6), ni, nj + character(len=128) :: mesg + character(len=32) :: fldnam + character(len=30) :: coord_mode + character(len=200) :: inputdir, basin_file + logical :: reentrant_x, reentrant_y, tripolar_N, symmetric + + if (associated(CS)) call mpp_error(FATAL,'Calling oda_init with associated control structure') + allocate(CS) +! Use ens1 parameters , this could be changed at a later time +! if it were desirable to have alternate parameters, e.g. for the grid +! for the analysis + call get_MOM_input(PF,dirs,ensemble_num=0) + call get_param(PF, "MOM", "ASSIM_METHOD", assim_method, & + "String which determines the data assimilation method" // & + "Valid methods are: \'EAKF\',\'OI\', and \'NO_ASSIM\'", default='NO_ASSIM') + call get_param(PF, "MOM", "ASSIM_FREQUENCY", CS%assim_frequency, & + "data assimilation frequency in hours") + call get_param(PF, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm , & + "If True, use the ALE algorithm (regridding/remapping).\n"//& + "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(PF, "MOM", "REENTRANT_X", CS%reentrant_x, & + "If true, the domain is zonally reentrant.", default=.true.) + call get_param(PF, "MOM", "REENTRANT_Y", CS%reentrant_y, & + "If true, the domain is meridionally reentrant.", & + default=.false.) + call get_param(PF,"MOM", "TRIPOLAR_N", CS%tripolar_N, & + "Use tripolar connectivity at the northern edge of the \n"//& + "domain. With TRIPOLAR_N, NIGLOBAL must be even.", & + default=.false.) + call get_param(PF,"MOM", "NIGLOBAL", CS%ni, & + "The total number of thickness grid points in the \n"//& + "x-direction in the physical domain.") + call get_param(PF,"MOM", "NJGLOBAL", CS%nj, & + "The total number of thickness grid points in the \n"//& + "y-direction in the physical domain.") + call get_param(PF, 'MOM', "INPUTDIR", inputdir) + inputdir = slasher(inputdir) + + select case(lowercase(trim(assim_method))) + case('eakf') + CS%assim_method = EAKF_ASSIM + case('oi') + CS%assim_method = OI_ASSIM + case('no_assim') + CS%assim_method = NO_ASSIM + case default + call mpp_error(FATAL,'Invalid assimilation method provided') + end select + + ens_info = get_ensemble_size() + CS%ensemble_size = ens_info(1) + npes_pm=ens_info(3) + CS%ensemble_id = get_ensemble_id() + !! Switch to global pelist + allocate(CS%ensemble_pelist(CS%ensemble_size,npes_pm)) + allocate(CS%filter_pelist(CS%ensemble_size*npes_pm)) + call get_ensemble_pelist(CS%ensemble_pelist,'ocean') + call get_ensemble_filter_pelist(CS%filter_pelist,'ocean') + + call set_current_pelist(CS%filter_pelist) + + allocate(CS%domains(CS%ensemble_size)) + CS%domains(CS%ensemble_id)%mpp_domain => G%Domain%mpp_domain + do n=1,CS%ensemble_size + if (.not. associated(CS%domains(n)%mpp_domain)) allocate(CS%domains(n)%mpp_domain) + call set_root_pe(CS%ensemble_pelist(n,1)) + call mpp_broadcast_domain(CS%domains(n)%mpp_domain) + enddo + call set_root_pe(CS%filter_pelist(1)) + allocate(CS%Grid) + ! params NIHALO_ODA, NJHALO_ODA set the DA halo size + call MOM_domains_init(CS%Grid%Domain,PF,param_suffix='_ODA') + allocate(HI) + call hor_index_init(CS%Grid%Domain, HI, PF, & + local_indexing=.false.) ! Use global indexing for DA + call verticalGridInit( PF, CS%GV ) + allocate(dG) + call create_dyn_horgrid(dG,HI) + call clone_MOM_domain(CS%Grid%Domain, dG%Domain,symmetric=.false.) + call set_grid_metrics(dG,PF) + call MOM_initialize_topography(dg%bathyT,dG%max_depth,dG,PF) + call MOM_initialize_coord(CS%GV, PF, .false., & + dirs%output_directory, tv_dummy, dG%max_depth) + call ALE_init(PF, CS%GV, dG%max_depth, CS%ALE_CS) + call MOM_grid_init(CS%Grid, PF, global_indexing=.true.) + call ALE_updateVerticalGridType(CS%ALE_CS,CS%GV) + call copy_dyngrid_to_MOM_grid(dG, CS%Grid) + CS%mpp_domain => CS%Grid%Domain%mpp_domain + CS%Grid%ke = CS%GV%ke + CS%nk = CS%GV%ke + ! initialize storage for prior and posterior + allocate(CS%Ocean_prior) + call init_ocean_ensemble(CS%Ocean_prior,CS%Grid,CS%GV,CS%ensemble_size) + allocate(CS%Ocean_posterior) + call init_ocean_ensemble(CS%Ocean_posterior,CS%Grid,CS%GV,CS%ensemble_size) + allocate(CS%tv) + + call get_param(PF, 'oda_driver', "REGRIDDING_COORDINATE_MODE", coord_mode, & + "Coordinate mode for vertical regridding.", & + default="ZSTAR", fail_if_missing=.false.) + call initialize_regridding(CS%regridCS, CS%GV, dG%max_depth,PF,'oda_driver',coord_mode,'','') + call initialize_remapping(CS%remapCS,'PLM') + call set_regrid_params(CS%regridCS, min_thickness=0.) + call mpp_get_data_domain(G%Domain%mpp_domain,isd,ied,jsd,jed) + if (.not. associated(CS%h)) then + allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke)); CS%h(:,:,:)=0.0 +! assign thicknesses + call ALE_initThicknessToCoord(CS%ALE_CS,G,CS%GV,CS%h) + endif + allocate(CS%tv%T(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%T(:,:,:)=0.0 + allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke)); CS%tv%S(:,:,:)=0.0 + + call set_axes_info(CS%Grid,CS%GV,PF,CS%diag_cs,set_vertical=.true.) + do n=1,CS%ensemble_size + write(fldnam,'(a,i2.2)') 'temp_prior_',n + CS%Ocean_prior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & + 'ocean potential temperature','degC') + write(fldnam,'(a,i2.2)') 'salt_prior_',n + CS%Ocean_prior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & + 'ocean salinity','psu') + write(fldnam,'(a,i2.2)') 'temp_posterior_',n + CS%Ocean_posterior%id_t(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & + 'ocean potential temperature','degC') + write(fldnam,'(a,i2.2)') 'salt_posterior_',n + CS%Ocean_posterior%id_s(n)=register_diag_field('ODA',trim(fldnam),CS%diag_cs%axesTL%handles,Time, & + 'ocean salinity','psu') + enddo + + call mpp_get_data_domain(CS%mpp_domain,isd,ied,jsd,jed) + allocate(CS%oda_grid) + CS%oda_grid%x => CS%Grid%geolonT + CS%oda_grid%y => CS%Grid%geolatT + + call get_param(PF, 'oda_driver', "BASIN_FILE", basin_file, & + "A file in which to find the basin masks, in variable 'basin'.", & + default="basin.nc") + basin_file = trim(inputdir) // trim(basin_file) + allocate(CS%oda_grid%basin_mask(isd:ied,jsd:jed)) + CS%oda_grid%basin_mask(:,:) = 0.0 + call MOM_read_data(basin_file,'basin',CS%oda_grid%basin_mask,CS%Grid%domain, timelevel=1) + +! get global grid information from ocean_model + allocate(T_grid) + allocate(T_grid%x(CS%ni,CS%nj)) + allocate(T_grid%y(CS%ni,CS%nj)) + allocate(T_grid%basin_mask(CS%ni,CS%nj)) + call mpp_global_field(CS%mpp_domain, CS%Grid%geolonT, T_grid%x) + call mpp_global_field(CS%mpp_domain, CS%Grid%geolatT, T_grid%y) + call mpp_global_field(CS%mpp_domain, CS%oda_grid%basin_mask, T_grid%basin_mask) + T_grid%ni = CS%ni + T_grid%nj = CS%nj + T_grid%nk = CS%nk + allocate(T_grid%mask(CS%ni,CS%nj,CS%nk)) + allocate(T_grid%z(CS%ni,CS%nj,CS%nk)) + allocate(global2D(CS%ni,CS%nj)) + allocate(global2D_old(CS%ni,CS%nj)) + T_grid%mask(:,:,:) = 0.0 + T_grid%z(:,:,:) = 0.0 + + do k = 1, CS%nk + call mpp_global_field(G%Domain%mpp_domain, CS%h(:,:,k), global2D) + do i=1, CS%ni; do j=1, CS%nj + if ( global2D(i,j) > 1 ) then + T_grid%mask(i,j,k) = 1.0 + endif + enddo ; enddo + if (k == 1) then + T_grid%z(:,:,k) = global2D/2 + else + T_grid%z(:,:,k) = T_grid%z(:,:,k-1) + (global2D + global2D_old)/2 + endif + global2D_old = global2D + enddo + + call ocean_da_core_init(CS%mpp_domain, T_grid, CS%Profiles, Time) + + CS%Time=Time + !! switch back to ensemble member pelist + call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + end subroutine init_oda + + subroutine set_prior_tracer(Time, G, GV, h, tv, CS) + type(time_type), intent(in) :: Time !< The current model time + type(ocean_grid_type), pointer :: G !< domain and grid information for ocean model + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + + type(ODA_CS), pointer :: CS !< ocean DA control structure + real, dimension(:,:,:), allocatable :: T, S + type(ocean_grid_type), pointer :: Grid=>NULL() + integer :: i,j, m, n, ss + integer :: is, ie, js, je + integer :: isc, iec, jsc, jec + integer :: isd, ied, jsd, jed + integer :: id + logical :: used + + ! return if not time for analysis + if (Time < CS%Time) return + + if (.not. associated(CS%Grid)) call MOM_ERROR(FATAL,'ODA_CS ensemble horizontal grid not associated') + if (.not. associated(CS%GV)) call MOM_ERROR(FATAL,'ODA_CS ensemble vertical grid not associated') + + !! switch to global pelist + call set_current_pelist(CS%filter_pelist) + if (is_root_pe()) print *, 'Setting prior' + + isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec + call mpp_get_compute_domain(CS%domains(CS%ensemble_id)%mpp_domain,is,ie,js,je) + call mpp_get_data_domain(CS%domains(CS%ensemble_id)%mpp_domain,isd,ied,jsd,jed) + allocate(T(isd:ied,jsd:jed,CS%nk)) + allocate(S(isd:ied,jsd:jed,CS%nk)) + + do j=js,je; do i=is,ie + call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%T(i,j,:), & + CS%nk, CS%h(i,j,:), T(i,j,:)) + call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & + CS%nk, CS%h(i,j,:), S(i,j,:)) + enddo ; enddo + + do m=1,CS%ensemble_size + call mpp_redistribute(CS%domains(m)%mpp_domain, T,& + CS%mpp_domain, CS%Ocean_prior%T(:,:,:,m), complete=.true.) + call mpp_redistribute(CS%domains(m)%mpp_domain, S,& + CS%mpp_domain, CS%Ocean_prior%S(:,:,:,m), complete=.true.) + if (CS%Ocean_prior%id_t(m)>0) & + used=send_data(CS%Ocean_prior%id_t(m), CS%Ocean_prior%T(isc:iec,jsc:jec,:,m), CS%Time) + if (CS%Ocean_prior%id_s(m)>0) & + used=send_data(CS%Ocean_prior%id_s(m), CS%Ocean_prior%S(isc:iec,jsc:jec,:,m), CS%Time) + enddo + deallocate(T,S) + + !! switch back to ensemble member pelist + call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + + return + + end subroutine set_prior_tracer + + !> Returns posterior adjustments or full state + !!Note that only those PEs associated with an ensemble member receive data + subroutine get_posterior_tracer(Time, CS, h, tv, increment) + type(time_type), intent(in) :: Time !< the current model time + type(ODA_CS), pointer :: CS !< ocean DA control structure + real, dimension(:,:,:), pointer :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(thermo_var_ptrs), pointer :: tv !< A structure pointing to various thermodynamic variables + logical, optional, intent(in) :: increment + + type(ocean_control_struct), pointer :: Ocean_increment=>NULL() + integer :: i, j, m + logical :: used, get_inc + + ! return if not analysis time (retain pointers for h and tv) + if (Time < CS%Time) return + + + !! switch to global pelist + call set_current_pelist(CS%filter_pelist) + if (is_root_pe()) print *, 'Getting posterior' + + get_inc = .true. + if (present(increment)) get_inc = increment + + if (get_inc) then + allocate(Ocean_increment) + call init_ocean_ensemble(Ocean_increment,CS%Grid,CS%GV,CS%ensemble_size) + Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T + Ocean_increment%S = CS%Ocean_posterior%S - CS%Ocean_prior%S + endif + do m=1,CS%ensemble_size + if (get_inc) then + call mpp_redistribute(CS%mpp_domain, Ocean_increment%T(:,:,:,m), & + CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + call mpp_redistribute(CS%mpp_domain, Ocean_increment%S(:,:,:,m), & + CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + else + call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m), & + CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + call mpp_redistribute(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m), & + CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + endif + enddo + + tv => CS%tv + h => CS%h + !! switch back to ensemble member pelist + call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + + end subroutine get_posterior_tracer + + subroutine oda(Time, CS) + type(time_type), intent(in) :: Time + type(oda_CS), intent(inout) :: CS + + integer :: i, j + integer :: m + integer :: yr, mon, day, hr, min, sec + + if ( Time >= CS%Time ) then + + !! switch to global pelist + call set_current_pelist(CS%filter_pelist) + + call get_profiles(Time, CS%Profiles, CS%CProfiles) +#ifdef ENABLE_ECDA + call ensemble_filter(CS%Ocean_prior, CS%Ocean_posterior, CS%CProfiles, CS%kdroot, CS%mpp_domain, CS%oda_grid) +#endif + + !! switch back to ensemble member pelist + call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + + endif + + return + end subroutine oda + + subroutine oda_end(CS) + type(ODA_CS), intent(inout) :: CS + + end subroutine oda_end + + subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) + type(ocean_control_struct), pointer :: CS !< Pointer to ODA control structure + type(ocean_grid_type), pointer :: Grid !< Pointer to ocean analysis grid + type(verticalGrid_type), pointer :: GV !< Pointer to DA vertical grid + integer, intent(in) :: ens_size !< ensemble size + + integer :: n,is,ie,js,je,nk + + nk=GV%ke + is=Grid%isd;ie=Grid%ied + js=Grid%jsd;je=Grid%jed + CS%ensemble_size=ens_size + allocate(CS%T(is:ie,js:je,nk,ens_size)) + allocate(CS%S(is:ie,js:je,nk,ens_size)) + allocate(CS%SSH(is:ie,js:je,ens_size)) + allocate(CS%id_t(ens_size));CS%id_t(:)=-1 + allocate(CS%id_s(ens_size));CS%id_s(:)=-1 +! allocate(CS%U(is:ie,js:je,nk,ens_size)) +! allocate(CS%V(is:ie,js:je,nk,ens_size)) +! allocate(CS%id_u(ens_size));CS%id_u(:)=-1 +! allocate(CS%id_v(ens_size));CS%id_v(:)=-1 + allocate(CS%id_ssh(ens_size));CS%id_ssh(:)=-1 + + return + end subroutine init_ocean_ensemble + + subroutine set_analysis_time(Time,CS) + type(time_type), intent(in) :: Time + type(ODA_CS), pointer, intent(inout) :: CS + + integer :: yr, mon, day, hr, min, sec + + if (Time >= CS%Time) then + CS%Time=increment_time(CS%Time,CS%assim_frequency*3600) + + call get_date(Time, yr, mon, day, hr, min, sec) + if (pe() == mpp_root_pe()) print *, 'Model Time: ', yr, mon, day, hr, min, sec + call get_date(CS%time, yr, mon, day, hr, min, sec) + if (pe() == mpp_root_pe()) print *, 'Assimilation Time: ', yr, mon, day, hr, min, sec + endif + if (CS%Time < Time) then + call MOM_error(FATAL, " set_analysis_time: " // & + "assimilation interval appears to be shorter than " // & + "the model timestep") + endif + return + + end subroutine set_analysis_time + + subroutine save_obs_diff(filename,CS) + character(len=*), intent(in) :: filename + type(ODA_CS), pointer, intent(in) :: CS + + integer :: fid ! profile file handle + type(ocean_profile_type), pointer :: Prof=>NULL() + + fid = open_profile_file(trim(filename), nvar=2, thread=MPP_SINGLE, fset=MPP_SINGLE) + Prof=>CS%CProfiles + + !! switch to global pelist + !call set_current_pelist(CS%filter_pelist) + + do while (associated(Prof)) + call write_profile(fid,Prof) + Prof=>Prof%cnext + enddo + call close_profile_file(fid) + + !! switch back to ensemble member pelist + !call set_current_pelist(CS%ensemble_pelist(CS%ensemble_id,:)) + + return + end subroutine save_obs_diff + + subroutine apply_oda_tracer_increments(dt,G,tv,h,CS) + real, intent(in) :: dt ! the tracer timestep (seconds) + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(thermo_var_ptrs), intent(inout) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< layer thickness (m or kg/m2) + type(ODA_CS), intent(inout) :: CS !< the data assimilation structure + + end subroutine apply_oda_tracer_increments +end module MOM_oda_driver_mod diff --git a/src/ocean_data_assim/core b/src/ocean_data_assim/core new file mode 120000 index 0000000000..e0a21d3192 --- /dev/null +++ b/src/ocean_data_assim/core @@ -0,0 +1 @@ +../../pkg/MOM6_DA_hooks/src/core \ No newline at end of file diff --git a/src/ocean_data_assim/geoKdTree b/src/ocean_data_assim/geoKdTree new file mode 120000 index 0000000000..61fd167bb6 --- /dev/null +++ b/src/ocean_data_assim/geoKdTree @@ -0,0 +1 @@ +../../pkg/geoKdTree \ No newline at end of file diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 46a3dcacad..10882aed75 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -519,8 +519,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, CS, hu, hv) ! Calculate viscosity for the main model to use if (CS%viscosity_coeff/=0.) then -!aja: should make range jsq:jeq, isq:ieq - do j=js-1,je+1 ; do i=is-1,ie+1 + do j=js,je ; do i=is,ie MEKE%Ku(i,j) = CS%viscosity_coeff*sqrt(2.*max(0.,MEKE%MEKE(i,j)))*LmixScale(i,j) enddo ; enddo call cpu_clock_begin(CS%id_clock_pass) @@ -1320,11 +1319,11 @@ end subroutine MEKE_end !! !! \subsection section_MEKE_references References !! -!! Jansen, M. F., A. J. Adcroft, R. Hallberg, and I. M. Held, 2015: Parameterization of eddy fluxes based on a mesoscale energy -!! budget. Ocean Modelling, 92, 28--41, http://doi.org/10.1016/j.ocemod.2015.05.007 . +!! Jansen, M. F., A. J. Adcroft, R. Hallberg, and I. M. Held, 2015: Parameterization of eddy fluxes based on a +!! mesoscale energy budget. Ocean Modelling, 92, 28--41, http://doi.org/10.1016/j.ocemod.2015.05.007 . !! -!! Marshall, D. P., and A. J. Adcroft, 2010: Parameterization of ocean eddies: Potential vorticity mixing, energetics and Arnold -!! first stability theorem. Ocean Modelling, 32, 188--204, http://doi.org/10.1016/j.ocemod.2010.02.001 . +!! Marshall, D. P., and A. J. Adcroft, 2010: Parameterization of ocean eddies: Potential vorticity mixing, energetics +!! and Arnold first stability theorem. Ocean Modelling, 32, 188--204, http://doi.org/10.1016/j.ocemod.2010.02.001 . end module MOM_MEKE diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0e02cefba2..11798d3bdb 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -237,7 +237,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, !! specify the spatially variable viscosities type(hor_visc_CS), pointer :: CS !< Pontrol structure returned by a previous !! call to hor_visc_init. - type(ocean_OBC_type), pointer, optional :: OBC !< Pointer to an open boundary condition type + type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type ! Arguments: ! (in) u - zonal velocity (m/s) @@ -433,7 +433,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, else do j=js-2,je+2 ; do I=Isq-1,Ieq+1 h_u(I,j) = 0.5 * (h(i,j,k) + h(i+1,j,k)) - enddo; enddo + enddo ; enddo do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 h_v(i,J) = 0.5 * (h(i,j,k) + h(i,j+1,k)) enddo ; enddo @@ -443,13 +443,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, ! thicknesses on open boundaries. if (apply_OBC) then ; do n=1,OBC%number_of_segments J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB - if (OBC%zero_strain .or. OBC%freeslip_strain) then + if (OBC%zero_strain .or. OBC%freeslip_strain .or. OBC%computed_strain) then if (OBC%segment(n)%is_N_or_S .and. (J >= js-2) .and. (J <= Jeq+1)) then do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB if (OBC%zero_strain) then dvdx(I,J) = 0. ; dudy(I,J) = 0. elseif (OBC%freeslip_strain) then dudy(I,J) = 0. + elseif (OBC%computed_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = 2.0*CS%DX_dyBu(I,J)*(OBC%segment(n)%tangential_vel(I,J,k) - u(I,j,k))*G%IdxCu(I,j) + else + dudy(I,J) = 2.0*CS%DX_dyBu(I,J)*(u(I,j+1,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdxCu(I,j+1) + endif + elseif (OBC%specified_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_N) then + dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j)*G%dxBu(I,J) + else + dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j+1)*G%dxBu(I,J) + endif endif enddo elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-2) .and. (I <= Ieq+1)) then @@ -458,6 +470,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, CS, dvdx(I,J) = 0. ; dudy(I,J) = 0. elseif (OBC%freeslip_strain) then dvdx(I,J) = 0. + elseif (OBC%computed_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)*(OBC%segment(n)%tangential_vel(I,J,k) - v(i,J,k))*G%IdyCv(i,J) + else + dvdx(I,J) = 2.0*CS%DY_dxBu(I,J)*(v(i+1,J,k) - OBC%segment(n)%tangential_vel(I,J,k))*G%IdyCv(i+1,J) + endif + elseif (OBC%specified_strain) then + if (OBC%segment(n)%direction == OBC_DIRECTION_E) then + dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i,J)*G%dxBu(I,J) + else + dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i+1,J)*G%dxBu(I,J) + endif endif enddo endif diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index fe91d988ac..3be1ae6192 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -284,7 +284,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & do j=jsd,jed ; do i=isd,ied ; test(i,j,1) = 1.0 ; test(i,j,2) = 0.0 ; enddo ; enddo do m=1,CS%nMode ; do fr=1,CS%nFreq call create_group_pass(pass_En, CS%En(:,:,:,fr,m), G%domain) - enddo; enddo + enddo ; enddo call create_group_pass(pass_test, test(:,:,1), test(:,:,2), G%domain, stagger=AGRID) call start_group_pass(pass_test, G%domain) @@ -324,7 +324,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset CS%En(i,j,a,fr,m) = 0.0 - if(abs(CS%En(i,j,a,fr,m))>1.0)then! only print if large + if (abs(CS%En(i,j,a,fr,m))>1.0)then! only print if large print *, 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g print *, 'En=',CS%En(i,j,a,fr,m) print *, 'Setting En to zero' @@ -440,8 +440,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & Ub(i,j,fr,m) = CS%wave_structure_CSp%Uavg_profile(i,j,nzm) Umax(i,j,fr,m) = maxval(CS%wave_structure_CSp%Uavg_profile(i,j,1:nzm)) !! for debugging print profile, etc. Delete later - !if(id_g .eq. 260 .and. & - ! jd_g .eq. 50 .and. & + !if (id_g == 260 .and. & + ! jd_g == 50 .and. & ! tot_En_mode(i,j,1,1)>500.0) then ! print *, 'Profiles for mode ',m,' and frequency ',fr ! print *, 'id_g=', id_g, 'jd_g=', jd_g @@ -654,17 +654,17 @@ subroutine sum_En(G, CS, En, label) call get_time(CS%Time, seconds) days = real(seconds) * Isecs_per_day - En_sum = 0.0; + 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 enddo En_sum_diff = En_sum - CS%En_sum - if (CS%En_sum .ne. 0.0) then + if (CS%En_sum /= 0.0) then En_sum_pdiff= (En_sum_diff/CS%En_sum)*100.0 else - En_sum_pdiff= 0.0; + En_sum_pdiff= 0.0 endif CS%En_sum = En_sum !! Print to screen @@ -761,7 +761,7 @@ subroutine itidal_lowmode_loss(G, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, ! do a=1,CS%nAngle ! frac_per_sector = En(i,j,a,fr,m)/En_tot ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if(TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then + ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt ! else ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than avalable, "// & @@ -796,10 +796,10 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) ! Arguments: ! (out) TKE_loss_sum - total energy loss rate due to specified mechanism, in W m-2. - if(mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet - if(mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet - if(mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing - if(mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet + if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet + if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet + if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing + if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet end subroutine get_lowmode_loss @@ -864,7 +864,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) enddo !### There should also be refraction due to cn.grad(grid_orientation). - CFL_ang(:,:,:) = 0.0; + CFL_ang(:,:,:) = 0.0 do j=js,je ! Copy En into angle space with halos. do a=1,na ; do i=is,ie @@ -920,10 +920,10 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) call MOM_error(WARNING, "refract: CFL exceeds 1.", .true.) if (CFL_ang(i,j,A) > 0.0) then ; CFL_ang(i,j,A) = 1.0 ; else ; CFL_ang(i,j,A) = -1.0 ; endif endif - enddo; enddo + enddo ; enddo ! Advect in angular space - if(.not.use_PPMang) then + if (.not.use_PPMang) then ! Use simple upwind do A=0,na ; do i=is,ie if (CFL_ang(i,j,A) > 0.0) then @@ -931,7 +931,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) else Flux_E(i,A) = CFL_ang(i,j,A) * En2d(i,A+1) endif - enddo; enddo + enddo ; enddo else ! Use PPM do i=is,ie @@ -941,7 +941,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) ! Update and copy back to En. do a=1,na ; do i=is,ie - !if(En2d(i,a)+(Flux_E(i,A-1)-Flux_E(i,A)) < 0.0)then ! for debugging + !if (En2d(i,a)+(Flux_E(i,A-1)-Flux_E(i,A)) < 0.0)then ! for debugging ! print *,"refract: OutFlux>Available" ; !stop !endif En(i,j,a) = En2d(i,a) + (Flux_E(i,A-1) - Flux_E(i,A)) @@ -1096,10 +1096,10 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) if (CS%corner_adv) then ! IMPLEMENT CORNER ADVECTION IN HORIZONTAL-------------------- - ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS; + ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS ! NOTE: THIS HAS NOT BE ADAPTED FOR REFLECTION YET (BDM)!! ! Fix indexing here later - speed(:,:) = 0; + speed(:,:) = 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)) * & @@ -1109,7 +1109,7 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) ! Apply the propagation WITH CORNER ADVECTION/FINITE VOLUME APPROACH. LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie call propagate_corner_spread(En(:,:,a), a, NAngle, speed, dt, G, CS, LB) - end do ! a-loop + enddo ! a-loop else ! IMPLEMENT PPM ADVECTION IN HORIZONTAL----------------------- ! These could be in the control structure, as they do not vary. @@ -1199,7 +1199,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS real :: TwoPi, Angle_size real :: energized_angle ! angle through center of current wedge real :: theta ! angle at edge of wedge - real :: Nsubrays ! number of sub-rays for averaging; + real :: Nsubrays ! number of sub-rays for averaging ! count includes the two rays that bound the current wedge, ! i.e. those at -dtheta/2 and +dtheta/2 from energized angle real :: I_Nsubwedges ! inverse of number of sub-wedges @@ -1323,7 +1323,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS aW = 0.0; aSW = 0.0; aS = 0.0; ! initialize areas aSE = 0.0; aE = 0.0; aC = 0.0; ! initialize areas if (0.0 <= theta .and. theta < 0.25*TwoPi) then - xCrn = x(I-1,J-1); yCrn = y(I-1,J-1); + 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)) @@ -1349,7 +1349,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yN - yNE)*(0.5*(xN + xNE)) aC = a1 + a2 + a3 + a4 elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then - xCrn = x(I,J-1); yCrn = y(I,J-1); + 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)) @@ -1375,7 +1375,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yNW - yN)*(0.5*(xNW + xN)) aC = a1 + a2 + a3 + a4 elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then - xCrn = x(I,J); yCrn = y(I,J); + xCrn = x(I,J); yCrn = y(I,J) ! east area a1 = (yE - ySE)*(0.5*(xE + xSE)) a2 = (ySE - yS)*(0.5*(xSE + xS)) @@ -1401,7 +1401,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yW - yCrn)*(0.5*(xW + xCrn)) aC = a1 + a2 + a3 + a4 elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then - xCrn = x(I-1,J); yCrn = y(I-1,J); + 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)) @@ -1413,7 +1413,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS 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 = a1 + a2 + a3 + a4 ! west area a1 = (yCrn - yS)*(0.5*(xCrn + xS)) a2 = (yS - ySW)*(0.5*(xS + xSW)) @@ -1436,7 +1436,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS enddo ! m-loop ! update energy in cell En(i,j) = sum(E_new)/Nsubrays - enddo; enddo + enddo ; enddo end subroutine propagate_corner_spread ! #@# This subroutine needs a doxygen description @@ -1519,7 +1519,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, Nangle, CS, LB) ! Update reflected energy (Jm-2) do j=jsh,jeh ; do i=ish,ieh !do a=1,CS%nAngle - ! if((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging + ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging ! print *,"propagate_x: OutFlux>Available" ; !stop ! endif !enddo @@ -1588,7 +1588,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, 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 (J) Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx (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 + !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging ! print *,"propagate_y: OutFlux>Available prior to reflection" ; !stop ! print *,"flux_y_south=",flux_y(i,J-1) ! print *,"flux_y_north=",flux_y(i,J) @@ -1616,7 +1616,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, Nangle, CS, LB) ! Update reflected energy (Jm-2) do j=jsh,jeh ; do i=ish,ieh !do a=1,CS%nAngle - ! if((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging + ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging ! print *,"propagate_y: OutFlux>Available" ; !stop ! endif !enddo @@ -1768,7 +1768,7 @@ subroutine reflect(En, NAngle, CS, G, LB) isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh - TwoPi = 8.0*atan(1.0); + TwoPi = 8.0*atan(1.0) Angle_size = TwoPi / (real(NAngle)) do a=1,NAngle @@ -1790,7 +1790,7 @@ subroutine reflect(En, NAngle, CS, G, LB) id_g = i + G%idg_offset ! redistribute energy in angular space if ray will hit boundary ! i.e., if energy is in a reflecting cell - if (angle_c(i,j) .ne. CS%nullangle) then + if (angle_c(i,j) /= CS%nullangle) then do a=1,NAngle if (En(i,j,a) > 0.0) then ! if ray is incident, keep specified boundary angle @@ -1818,7 +1818,7 @@ subroutine reflect(En, NAngle, CS, G, LB) endif a_r = nint(angle_r/Angle_size) + 1 do while (a_r > Nangle) ; a_r = a_r - Nangle ; enddo - if (a .ne. a_r) then + if (a /= a_r) then En_reflected(a_r) = part_refl(i,j)*En(i,j,a) En(i,j,a) = (1.0-part_refl(i,j))*En(i,j,a) endif @@ -2069,7 +2069,7 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) slp(i,j) = sign(1.,slp(i,j)) * min(abs(slp(i,j)), 2. * min(dMx, dMn)) ! * (G%mask2dT(i-1,j) * G%mask2dT(i,j) * G%mask2dT(i+1,j)) endif - enddo; enddo + enddo ; enddo do j=jsl,jel ; do i=isl,iel ! Neighboring values should take into account any boundaries. The 3 @@ -2081,7 +2081,7 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) ! Left/right values following Eq. B2 in Lin 1994, MWR (132) h_l(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) h_r(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) - enddo; enddo + enddo ; enddo endif call PPM_limit_pos(h_in, h_l, h_r, 0.0, G, isl, iel, jsl, jel) @@ -2498,11 +2498,11 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Restrict rms topo to 10 percent of column depth. h2(i,j) = min(0.01*G%bathyT(i,j)**2, h2(i,j)) - ! Compute the fixed part; units are [kg m-2] here; + ! Compute the fixed part; units are [kg m-2] here ! will be multiplied by N and En to get into [W m-2] CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& kappa_itides * h2(i,j) - enddo; enddo + enddo ; enddo ! Read in prescribed coast/ridge/shelf angles from file call get_param(param_file, mdl, "REFL_ANGLE_FILE", refl_angle_file, & @@ -2516,7 +2516,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) G%domain, timelevel=1) ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec - if(is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle + if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle enddo ; enddo call pass_var(CS%refl_angle,G%domain) @@ -2536,7 +2536,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) do j=jsd,jed do i=isd,ied ! flag cells with partial reflection - if (CS%refl_angle(i,j) .ne. CS%nullangle .and. & + if (CS%refl_angle(i,j) /= CS%nullangle .and. & CS%refl_pref(i,j) < 1.0 .and. CS%refl_pref(i,j) > 0.0) then CS%refl_pref_logical(i,j) = .true. endif @@ -2556,7 +2556,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) do i=isd,ied; do j=jsd,jed if (ridge_temp(i,j) == 1) then; CS%refl_dbl(i,j) = .true. else ; CS%refl_dbl(i,j) = .false. ; endif - enddo; enddo + enddo ; enddo ! Read in prescribed land mask from file (if overwriting -BDM). ! This should be done in MOM_initialize_topography subroutine diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 226f40f59b..ecc586d025 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -22,7 +22,7 @@ module MOM_lateral_mixing_coeffs #include !> Variable mixing coefficients -type, public :: VarMix_CS ; +type, public :: VarMix_CS logical :: use_variable_mixing !< If true, use the variable mixing. logical :: Resoln_scaled_Kh !< If true, scale away the Laplacian viscosity !! when the deformation radius is well resolved. @@ -146,13 +146,13 @@ subroutine calc_resoln_function(h, tv, G, GV, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - if (.not. ASSOCIATED(CS)) call MOM_error(FATAL, "calc_resoln_function:"// & + if (.not. associated(CS)) call MOM_error(FATAL, "calc_resoln_function:"// & "Module must be initialized before it is used.") if (CS%calculate_cg1) then - if (.not. ASSOCIATED(CS%cg1)) call MOM_error(FATAL, & + if (.not. associated(CS%cg1)) call MOM_error(FATAL, & "calc_resoln_function: %cg1 is not associated with Resoln_scaled_Kh.") if (CS%khth_use_ebt_struct) then - if (.not. ASSOCIATED(CS%ebt_struct)) call MOM_error(FATAL, & + if (.not. associated(CS%ebt_struct)) call MOM_error(FATAL, & "calc_resoln_function: %ebt_struct is not associated with RESOLN_USE_EBT.") if (CS%Resoln_use_ebt) then ! Both resolution fn and vertical structure are using EBT @@ -174,7 +174,7 @@ subroutine calc_resoln_function(h, tv, G, GV, CS) ! Calculate and store the ratio between deformation radius and grid-spacing ! at h-points (non-dimensional). if (CS%calculate_rd_dx) then - if (.not. ASSOCIATED(CS%Rd_dx_h)) call MOM_error(FATAL, & + if (.not. associated(CS%Rd_dx_h)) call MOM_error(FATAL, & "calc_resoln_function: %Rd_dx_h is not associated with calculate_rd_dx.") !$OMP parallel default(none) shared(is,ie,js,je,CS) !$OMP do @@ -190,29 +190,29 @@ subroutine calc_resoln_function(h, tv, G, GV, CS) if (.not. CS%calculate_res_fns) return - if (.not. ASSOCIATED(CS%Res_fn_h)) call MOM_error(FATAL, & + if (.not. associated(CS%Res_fn_h)) call MOM_error(FATAL, & "calc_resoln_function: %Res_fn_h is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%Res_fn_q)) call MOM_error(FATAL, & + if (.not. associated(CS%Res_fn_q)) call MOM_error(FATAL, & "calc_resoln_function: %Res_fn_q is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%Res_fn_u)) call MOM_error(FATAL, & + if (.not. associated(CS%Res_fn_u)) call MOM_error(FATAL, & "calc_resoln_function: %Res_fn_u is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%Res_fn_v)) call MOM_error(FATAL, & + if (.not. associated(CS%Res_fn_v)) call MOM_error(FATAL, & "calc_resoln_function: %Res_fn_v is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%f2_dx2_h)) call MOM_error(FATAL, & + if (.not. associated(CS%f2_dx2_h)) call MOM_error(FATAL, & "calc_resoln_function: %f2_dx2_h is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%f2_dx2_q)) call MOM_error(FATAL, & + if (.not. associated(CS%f2_dx2_q)) call MOM_error(FATAL, & "calc_resoln_function: %f2_dx2_q is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%f2_dx2_u)) call MOM_error(FATAL, & + if (.not. associated(CS%f2_dx2_u)) call MOM_error(FATAL, & "calc_resoln_function: %f2_dx2_u is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%f2_dx2_v)) call MOM_error(FATAL, & + if (.not. associated(CS%f2_dx2_v)) call MOM_error(FATAL, & "calc_resoln_function: %f2_dx2_v is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%beta_dx2_h)) call MOM_error(FATAL, & + if (.not. associated(CS%beta_dx2_h)) call MOM_error(FATAL, & "calc_resoln_function: %beta_dx2_h is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%beta_dx2_q)) call MOM_error(FATAL, & + if (.not. associated(CS%beta_dx2_q)) call MOM_error(FATAL, & "calc_resoln_function: %beta_dx2_q is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%beta_dx2_u)) call MOM_error(FATAL, & + if (.not. associated(CS%beta_dx2_u)) call MOM_error(FATAL, & "calc_resoln_function: %beta_dx2_u is not associated with Resoln_scaled_Kh.") - if (.not. ASSOCIATED(CS%beta_dx2_v)) call MOM_error(FATAL, & + if (.not. associated(CS%beta_dx2_v)) call MOM_error(FATAL, & "calc_resoln_function: %beta_dx2_v is not associated with Resoln_scaled_Kh.") ! Do this calculation on the extent used in MOM_hor_visc.F90, and @@ -389,7 +389,7 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, CS) real, dimension(SZIB_(G), SZJ_(G), SZK_(G)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points real, dimension(SZI_(G), SZJB_(G), SZK_(G)+1) :: N2_v ! Square of Brunt-Vaisala freq at u-points - if (.not. ASSOCIATED(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& + if (.not. associated(CS)) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions:"//& "Module must be initialized before it is used.") if (CS%calculate_Eady_growth_rate) then @@ -444,12 +444,12 @@ subroutine calc_Visbeck_coeffs(h, e, slope_x, slope_y, N2_u, N2_v, G, GV, CS) real :: S2_u(SZIB_(G), SZJ_(G)) real :: S2_v(SZI_(G), SZJB_(G)) - if (.not. ASSOCIATED(CS)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") if (.not. CS%calculate_Eady_growth_rate) return - if (.not. ASSOCIATED(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. associated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & "%SN_u is not associated with use_variable_mixing.") - if (.not. ASSOCIATED(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. associated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & "%SN_v is not associated with use_variable_mixing.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -606,12 +606,12 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) real :: SN_u_local(SZIB_(G), SZJ_(G),SZK_(G)) real :: SN_v_local(SZI_(G), SZJB_(G),SZK_(G)) - if (.not. ASSOCIATED(CS)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. associated(CS)) call MOM_error(FATAL, "calc_slope_function:"// & "Module must be initialized before it is used.") if (.not. CS%calculate_Eady_growth_rate) return - if (.not. ASSOCIATED(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. associated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & "%SN_u is not associated with use_variable_mixing.") - if (.not. ASSOCIATED(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. associated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & "%SN_v is not associated with use_variable_mixing.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -685,7 +685,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) enddo ! k !$OMP do - do j = js,je; + do j = js,je do k=nz,CS%VarMix_Ktop,-1 ; do I=is-1,ie CS%SN_u(I,j) = CS%SN_u(I,j) + SN_u_local(I,j,k) enddo ; enddo @@ -934,10 +934,10 @@ subroutine VarMix_init(Time, G, param_file, diag, CS) "used which introduced potential restart issues. This flag will be \n"//& "deprecated in a future release.", default=.false.) if (CS%interpolate_Res_fn) then - if (CS%Res_coef_visc .ne. CS%Res_coef_khth) call MOM_error(FATAL, & + if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, & "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_SCALE_COEF.") - if (CS%Res_fn_power_visc .ne. CS%Res_fn_power_khth) call MOM_error(FATAL, & + if (CS%Res_fn_power_visc /= CS%Res_fn_power_khth) call MOM_error(FATAL, & "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") endif @@ -1053,8 +1053,8 @@ end subroutine VarMix_init !! r(\Delta,L_d) = \frac{1}{1+(\alpha R)^p} !! \f] !! -!! The resolution function can be applied independently to thickness diffusion (module mom_thickness_diffuse), tracer diffusion (mom_tracer_hordiff) -!! lateral viscosity (mom_hor_visc). +!! The resolution function can be applied independently to thickness diffusion (module mom_thickness_diffuse), +!! tracer diffusion (mom_tracer_hordiff) lateral viscosity (mom_hor_visc). !! !! Robert Hallberg, 2013: Using a resolution function to regulate parameterizations of oceanic mesoscale eddy effects. !! Ocean Modelling, 71, pp 92-103. http://dx.doi.org/10.1016/j.ocemod.2013.08.007 @@ -1075,8 +1075,8 @@ end subroutine VarMix_init !! !! \section section_Vicbeck Visbeck diffusivity !! -!! This module also calculates factors used in setting the thickness diffusivity similar to a Visbeck et al., 1997, scheme. -!! The factors are combined in mom_thickness_diffuse::thickness_diffuse() but calculated in this module. +!! This module also calculates factors used in setting the thickness diffusivity similar to a Visbeck et al., 1997, +!! scheme. The factors are combined in mom_thickness_diffuse::thickness_diffuse() but calculated in this module. !! !! \f[ !! \kappa_h = \alpha_s L_s^2 S N @@ -1098,9 +1098,9 @@ end subroutine VarMix_init !! !! \section section_vertical_structure_khth Vertical structure function for KhTh !! -!! The thickness diffusivity can be prescribed a vertical distribution with the shape of the equivalent barotropic velocity mode. -!! The structure function is stored in the control structure for thie module (varmix_cs) but is calculated use subroutines in -!! mom_wave_speed. +!! The thickness diffusivity can be prescribed a vertical distribution with the shape of the equivalent barotropic +!! velocity mode. The structure function is stored in the control structure for thie module (varmix_cs) but is +!! calculated using subroutines in mom_wave_speed. !! !! | Symbol | Module parameter | !! | ------ | --------------- | diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 840a0c3373..ba76c208cc 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -93,7 +93,8 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment (sec) - real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by PBL scheme (H units) + real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the + !! PBL scheme (H units) type(VarMix_CS), pointer :: VarMix !< Container for derived fields type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure @@ -119,7 +120,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables structure type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment (sec) - real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by PBL scheme, in m (not H) + real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the + !! PBL scheme, in m (not H) type(VarMix_CS), pointer :: VarMix !< Container for derived fields type(mixedlayer_restrat_CS), pointer :: CS !< Module control structure ! Local variables @@ -215,7 +217,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var enddo ! k-loop do i = is-1, ie+1 MLD_fast(i,j) = CS%MLE_MLD_stretch * MLD_fast(i,j) - if ((MLD_fast(i,j)==0.) .and. (deltaRhoAtK(i) 0.) Resoln_scaled = VarMix%Resoln_scaled_KhTh use_stored_slopes = VarMix%use_stored_slopes @@ -312,8 +312,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS int_slope_u, int_slope_v) endif - if (associated(MEKE) .AND. ASSOCIATED(VarMix)) then - if (ASSOCIATED(MEKE%Rd_dx_h) .and. ASSOCIATED(VarMix%Rd_dx_h)) then + if (associated(MEKE) .AND. associated(VarMix)) then + if (associated(MEKE%Rd_dx_h) .and. associated(VarMix%Rd_dx_h)) then !$OMP parallel do default(none) shared(is,ie,js,je,MEKE,VarMix) do j=js,je ; do i=is,ie MEKE%Rd_dx_h(i,j) = VarMix%Rd_dx_h(i,j) @@ -338,16 +338,16 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS ! depth will place a spurious depth dependence to the diagnosed KH_t. if (CS%id_KH_t > 0 .or. CS%id_KH_t1 > 0) then do k=1,nz - ! thicknesses across u and v faces, converted to 0/1 mask; + ! thicknesses across u and v faces, converted to 0/1 mask ! layer average of the interface diffusivities KH_u and KH_v do j=js,je ; do I=is-1,ie hu(I,j) = 2.0*h(i,j,k)*h(i+1,j,k)/(h(i,j,k)+h(i+1,j,k)+h_neglect) - if(hu(I,j) /= 0.0) hu(I,j) = 1.0 + if (hu(I,j) /= 0.0) hu(I,j) = 1.0 KH_u_lay(I,j) = 0.5*(KH_u(I,j,k)+KH_u(I,j,k+1)) enddo ; enddo do J=js-1,je ; do i=is,ie hv(i,J) = 2.0*h(i,j,k)*h(i,j+1,k)/(h(i,j,k)+h(i,j+1,k)+h_neglect) - if(hv(i,J) /= 0.0) hv(i,J) = 1.0 + if (hv(i,J) /= 0.0) hv(i,J) = 1.0 KH_v_lay(i,J) = 0.5*(KH_v(i,J,k)+KH_v(i,J,k+1)) enddo ; enddo ! diagnose diffusivity at T-point @@ -357,8 +357,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS / (hu(I-1,j)+hu(I,j)+hv(i,J-1)+hv(i,J)+h_neglect) enddo ; enddo enddo - if(CS%id_KH_t > 0) call post_data(CS%id_KH_t, KH_t, CS%diag) - if(CS%id_KH_t1 > 0) call post_data(CS%id_KH_t1, KH_t(:,:,1), CS%diag) + if (CS%id_KH_t > 0) call post_data(CS%id_KH_t, KH_t, CS%diag) + if (CS%id_KH_t1 > 0) call post_data(CS%id_KH_t1, KH_t(:,:,1), CS%diag) endif endif @@ -367,11 +367,11 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS 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 - if (ASSOCIATED(CDp%uhGM)) CDp%uhGM(I,j,k) = uhD(I,j,k) + if (associated(CDp%uhGM)) CDp%uhGM(I,j,k) = uhD(I,j,k) enddo ; enddo do J=js-1,je ; do i=is,ie vhtr(i,J,k) = vhtr(i,J,k) + vhD(i,J,k)*dt - if (ASSOCIATED(CDp%vhGM)) CDp%vhGM(i,J,k) = vhD(i,J,k) + if (associated(CDp%vhGM)) CDp%vhGM(i,J,k) = vhD(i,J,k) enddo ; enddo do j=js,je ; do i=is,ie h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * & @@ -404,8 +404,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg/m2) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface positions (m) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: Kh_u !< Thickness diffusivity on interfaces at u points (m2/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces at v points (m2/s) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(in) :: Kh_u !< Thickness diffusivity on interfaces + !! at u points (m2/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces + !! at v points (m2/s) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(out) :: uhD !< Zonal mass fluxes (m3/s) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(out) :: vhD !< Meridional mass fluxes (m3/s) @@ -415,10 +417,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from the - !! interface slopes without consideration of density gradients. + !! interface slopes without consideration of + !! density gradients. real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), optional, intent(in) :: int_slope_v !< Ratio that determine how much of !! the isopycnal slopes are taken directly from the - !! interface slopes without consideration of density gradients. + !! interface slopes without consideration of + !! density gradients. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), optional, intent(in) :: slope_x !< Isopycnal slope at u-points real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), optional, intent(in) :: slope_y !< Isopycnal slope at v-points ! Local variables @@ -529,8 +533,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV nk_linear = max(GV%nkml, 1) find_work = .false. - if (associated(MEKE)) find_work = ASSOCIATED(MEKE%GM_src) - find_work = (ASSOCIATED(CS%GMwork) .or. find_work) + if (associated(MEKE)) find_work = associated(MEKE%GM_src) + find_work = (associated(CS%GMwork) .or. find_work) if (use_EOS) then call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth, dt, T, S, G, GV, 1) @@ -1130,8 +1134,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Note that the units of Work_v and Work_u are W, while Work_h is W m-2. Work_h = 0.5 * G%IareaT(i,j) * & ((Work_u(I-1,j) + Work_u(I,j)) + (Work_v(i,J-1) + Work_v(i,J))) - if (ASSOCIATED(CS%GMwork)) CS%GMwork(i,j) = Work_h - if (associated(MEKE)) then ; if (ASSOCIATED(MEKE%GM_src)) then + if (associated(CS%GMwork)) CS%GMwork(i,j) = Work_h + if (associated(MEKE)) then ; if (associated(MEKE%GM_src)) then MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + Work_h endif ; endif enddo ; enddo ; endif @@ -1185,19 +1189,25 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: e !< Interface positions (m) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces at u points (m2/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: Kh_v !< Thickness diffusivity on interfaces at u points (m2/s) - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable thickness diffusivity at u points (m2/s) - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity at v points (m2/s) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces + !! at u points (m2/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1), intent(inout) :: Kh_v !< Thickness diffusivity on interfaces + !! at v points (m2/s) + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable thickness diffusivity + !! at u points (m2/s) + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity + !! at v points (m2/s) type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, intent(in) :: dt !< Time increment (s) type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+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. + !! interface slopes without consideration of + !! density gradients. real, dimension(SZI_(G),SZJB_(G),SZK_(G)+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. + !! interface slopes without consideration of + !! density gradients. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & de_top ! The distances between the top of a layer and the top of the @@ -1759,7 +1769,8 @@ subroutine thickness_diffuse_init(Time, G, GV, param_file, diag, CDp, CS) default=7.2921e-5, do_not_log=.not.CS%use_FGNV_streamfn) if (CS%use_FGNV_streamfn) CS%N2_floor = (strat_floor*omega)**2 call get_param(param_file, mdl, "DEBUG", CS%debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) if (GV%Boussinesq) then ; flux_to_kg_per_s = GV%Rho0 @@ -1819,7 +1830,7 @@ end subroutine thickness_diffuse_init !> Deallocate the thickness diffusion control structure subroutine thickness_diffuse_end(CS) type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion - if(associated(CS)) deallocate(CS) + if (associated(CS)) deallocate(CS) end subroutine thickness_diffuse_end !> \namespace mom_thickness_diffuse @@ -1845,10 +1856,11 @@ end subroutine thickness_diffuse_end !! \f[ !! \vec{\psi} = \kappa_h \frac{M^2}{\sqrt{N^4 + M^4}} !! \f] -!! since the quantity \f$\frac{M^2}{\sqrt{N^2 + M^2}}\f$ is bounded between $-1$ and $1$ and does not change sign if \f$N^2<0\f$. +!! since the quantity \f$\frac{M^2}{\sqrt{N^2 + M^2}}\f$ is bounded between $-1$ and $1$ and does not change sign +!! if \f$N^2<0\f$. !! -!! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the vertically elliptic -!! equation: +!! Optionally, the method of Ferrari et al, 2010, can be used to obtain the streamfunction which solves the +!! vertically elliptic equation: !! \f[ !! \gamma_F \partial_z c^2 \partial_z \psi - N_*^2 \psi = ( 1 + \gamma_F ) \kappa_h N_*^2 \frac{M^2}{\sqrt{N^4+M^4}} !! \f] @@ -1864,22 +1876,23 @@ end subroutine thickness_diffuse_end !! \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, -!! \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 Brunt-Vaisala frequency -!! prescribed by Visbeck et al., 1996. +!! \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. !! !! 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). !! \f[ -!! \kappa_h \leftarrow \min{\left( \kappa_{max}, \kappa_{cfl}, \max{\left( \kappa_{min}, \kappa_h \right)} \right)} f(c_g,z) +!! \kappa_h \leftarrow \min{\left( \kappa_{max}, \kappa_{cfl}, \max{\left( \kappa_{min}, \kappa_h \right)} \right)} +!! f(c_g,z) !! \f] !! !! where \f$f(c_g,z)\f$ is a vertical structure function. !! \f$f(c_g,z)\f$ is calculated in module mom_lateral_mixing_coeffs. -!! If KHTH_USE_EBT_STRUCT=True then \f$f(c_g,z)\f$ is set to look like the equivalent barotropic modal velocity structure. -!! Otherwise \f$f(c_g,z)=1\f$ and the diffusivity is independent of depth. +!! If KHTH_USE_EBT_STRUCT=True then \f$f(c_g,z)\f$ is set to look like the equivalent barotropic +!! modal velocity structure. Otherwise \f$f(c_g,z)=1\f$ and the diffusivity is independent of depth. !! !! In order to calculate meaningful slopes in vanished layers, temporary copies of the thermodynamic variables !! are passed through a vertical smoother, function vert_fill_ts(): diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index e7fe81dbd8..1b2dd77928 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -21,7 +21,6 @@ module MOM_ALE_sponge use MOM_time_manager, only : time_type, init_external_field, get_external_field_size, time_interp_external_init use MOM_remapping, only : remapping_cs, remapping_core_h, initialize_remapping use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer - ! GMM - Planned extension: Support for time varying sponge targets. implicit none ; private @@ -44,6 +43,7 @@ module MOM_ALE_sponge end interface !< Publicly available functions public set_up_ALE_sponge_field, set_up_ALE_sponge_vel_field +public get_ALE_sponge_thicknesses, get_ALE_sponge_nz_data public initialize_ALE_sponge, apply_ALE_sponge, ALE_sponge_end, init_ALE_sponge_diags type :: p3d @@ -114,12 +114,14 @@ module MOM_ALE_sponge ! heights. subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_data) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time, in s-1 (in). - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse for model parameter values (in). - type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control structure for this module (in/out). - real, dimension(SZI_(G),SZJ_(G),nz_data), intent(in) :: data_h !< The thicknesses of the sponge input layers. (in). - integer, intent(in) :: nz_data !< The total number of sponge input layers (in). + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + integer, intent(in) :: nz_data !< The total number of sponge input layers (in). + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time, in s-1 (in). + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values (in). + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module (in/out). + real, dimension(SZI_(G),SZJ_(G),nz_data), intent(in) :: data_h !< The thicknesses of the sponge input layers. ! This include declares and sets the variable "version". @@ -166,6 +168,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + CS%new_sponges = .false. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed @@ -178,13 +181,10 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ CS%num_col = CS%num_col + 1 enddo ; enddo - if (CS%num_col > 0) then - allocate(CS%Iresttime_col(CS%num_col)) ; CS%Iresttime_col = 0.0 allocate(CS%col_i(CS%num_col)) ; CS%col_i = 0 allocate(CS%col_j(CS%num_col)) ; CS%col_j = 0 - ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -194,16 +194,12 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ col = col +1 endif enddo ; enddo - ! same for total number of arbritary layers and correspondent data CS%nz_data = nz_data allocate(CS%Ref_h%p(CS%nz_data,CS%num_col)) do col=1,CS%num_col ; do K=1,CS%nz_data CS%Ref_h%p(K,col) = data_h(CS%col_i(col),CS%col_j(col),K) - enddo; enddo - CS%new_sponges = .false. - - + enddo ; enddo endif total_sponge_cols = CS%num_col @@ -217,86 +213,135 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, param_file, CS, data_h, nz_ if (CS%sponge_uv) then - allocate(data_hu(G%isdB:G%iedB,G%jsd:G%jed,nz_data)); data_hu(:,:,:)=0.0 - allocate(data_hv(G%isd:G%ied,G%jsdB:G%jedB,nz_data)); data_hv(:,:,:)=0.0 - allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 - allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 + allocate(data_hu(G%isdB:G%iedB,G%jsd:G%jed,nz_data)); data_hu(:,:,:)=0.0 + allocate(data_hv(G%isd:G%ied,G%jsdB:G%jedB,nz_data)); data_hv(:,:,:)=0.0 + allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed)); Iresttime_u(:,:)=0.0 + allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB)); Iresttime_v(:,:)=0.0 - ! u points - CS%num_col_u = 0 ; !CS%fldno_u = 0 - do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB - data_hu(I,j,:) = 0.5 * (data_h(i,j,:) + data_h(i+1,j,:)) - Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & - CS%num_col_u = CS%num_col_u + 1 - enddo; enddo + ! u points + CS%num_col_u = 0 ; !CS%fldno_u = 0 + do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB + data_hu(I,j,:) = 0.5 * (data_h(i,j,:) + data_h(i+1,j,:)) + Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + CS%num_col_u = CS%num_col_u + 1 + enddo ; enddo - if (CS%num_col_u > 0) then + if (CS%num_col_u > 0) then - allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 - allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 - allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 + allocate(CS%Iresttime_col_u(CS%num_col_u)) ; CS%Iresttime_col_u = 0.0 + allocate(CS%col_i_u(CS%num_col_u)) ; CS%col_i_u = 0 + allocate(CS%col_j_u(CS%num_col_u)) ; CS%col_j_u = 0 - ! pass indices, restoring time to the CS structure - col = 1 - do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>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 - endif - enddo ; enddo + ! pass indices, restoring time to the CS structure + col = 1 + do j=CS%jsc,CS%jec ; do I=CS%iscB,CS%iecB + if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>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 + endif + enddo ; enddo - ! same for total number of arbritary layers and correspondent data + ! same for total number of arbritary layers and correspondent data - allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) - do col=1,CS%num_col_u ; do K=1,CS%nz_data - CS%Ref_hu%p(K,col) = data_hu(CS%col_i_u(col),CS%col_j_u(col),K) - enddo; enddo - endif - total_sponge_cols_u = CS%num_col_u - call sum_across_PEs(total_sponge_cols_u) - call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & - "The total number of columns where sponges are applied at u points.") + allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) + do col=1,CS%num_col_u ; do K=1,CS%nz_data + CS%Ref_hu%p(K,col) = data_hu(CS%col_i_u(col),CS%col_j_u(col),K) + enddo ; enddo + endif + total_sponge_cols_u = CS%num_col_u + call sum_across_PEs(total_sponge_cols_u) + call log_param(param_file, mdl, "!Total sponge columns at u points", total_sponge_cols_u, & + "The total number of columns where sponges are applied at u points.") - ! v points - CS%num_col_v = 0 ; !CS%fldno_v = 0 - do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec - data_hv(i,J,:) = 0.5 * (data_h(i,j,:) + data_h(i,j+1,:)) - Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & - CS%num_col_v = CS%num_col_v + 1 - enddo; enddo + ! v points + CS%num_col_v = 0 ; !CS%fldno_v = 0 + do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec + data_hv(i,J,:) = 0.5 * (data_h(i,j,:) + data_h(i,j+1,:)) + Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + CS%num_col_v = CS%num_col_v + 1 + enddo ; enddo - if (CS%num_col_v > 0) then + if (CS%num_col_v > 0) then + + allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 + allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 + allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 + + ! pass indices, restoring time to the CS structure + col = 1 + do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec + if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>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 + endif + enddo ; enddo + + ! same for total number of arbritary layers and correspondent data + allocate(CS%Ref_hv%p(CS%nz_data,CS%num_col_v)) + do col=1,CS%num_col_v ; do K=1,CS%nz_data + CS%Ref_hv%p(K,col) = data_hv(CS%col_i_v(col),CS%col_j_v(col),K) + enddo ; enddo + endif + total_sponge_cols_v = CS%num_col_v + call sum_across_PEs(total_sponge_cols_v) + call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & + "The total number of columns where sponges are applied at v points.") + endif - allocate(CS%Iresttime_col_v(CS%num_col_v)) ; CS%Iresttime_col_v = 0.0 - allocate(CS%col_i_v(CS%num_col_v)) ; CS%col_i_v = 0 - allocate(CS%col_j_v(CS%num_col_v)) ; CS%col_j_v = 0 +end subroutine initialize_ALE_sponge_fixed - ! pass indices, restoring time to the CS structure - col = 1 - do J=CS%jscB,CS%jecB ; do i=CS%isc,CS%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>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 - endif - enddo ; enddo +!> Return the number of layers in the data with a fixed ALE sponge, or 0 if there are +!! no sponge columns on this PE. +function get_ALE_sponge_nz_data(CS) + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for the ALE_sponge module. + integer :: get_ALE_sponge_nz_data !< The number of layers in the fixed sponge data. - ! same for total number of arbritary layers and correspondent data - allocate(CS%Ref_hv%p(CS%nz_data,CS%num_col_v)) - do col=1,CS%num_col_v ; do K=1,CS%nz_data - CS%Ref_hv%p(K,col) = data_hv(CS%col_i_v(col),CS%col_j_v(col),K) - enddo ; enddo - endif - total_sponge_cols_v = CS%num_col_v - call sum_across_PEs(total_sponge_cols_v) - call log_param(param_file, mdl, "!Total sponge columns at v points", total_sponge_cols_v, & - "The total number of columns where sponges are applied at v points.") + if (associated(CS)) then + get_ALE_sponge_nz_data = CS%nz_data + else + get_ALE_sponge_nz_data = 0 + endif +end function get_ALE_sponge_nz_data + +!> Return the thicknesses used for the data with a fixed ALE sponge +subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, allocatable, dimension(:,:,:), & + intent(inout) :: data_h !< The thicknesses of the sponge input layers. + logical, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: sponge_mask !< A logical mask that is true where + !! sponges are being applied. + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for the ALE_sponge module. + integer :: c, i, j, k + + if (allocated(data_h)) call MOM_error(FATAL, & + "get_ALE_sponge_thicknesses called with an allocated data_h.") + + if (.not.associated(CS)) then + ! There are no sponge points on this PE. + allocate(data_h(G%isd:G%ied,G%jsd:G%jed,1)) ; data_h(:,:,:) = -1.0 + sponge_mask(:,:) = .false. + return endif -end subroutine initialize_ALE_sponge_fixed + allocate(data_h(G%isd:G%ied,G%jsd:G%jed,CS%nz_data)) ; data_h(:,:,:) = -1.0 + sponge_mask(:,:) = .false. + + do c=1,CS%num_col + i = CS%col_i(c) ; j = CS%col_j(c) + sponge_mask(i,j) = .true. + do k=1,CS%nz_data + data_h(i,j,k) = CS%Ref_h%p(k,c) + enddo + enddo + +end subroutine get_ALE_sponge_thicknesses !> This subroutine determines the number of points which are within ! sponges in this computational domain. Only points that have @@ -305,10 +350,12 @@ end subroutine initialize_ALE_sponge_fixed ! heights. subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time, in s-1 (in). - type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse for model parameter values (in). - type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control structure for this module (in/out). + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time, in s-1 (in). + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse + !! for model parameter values (in). + type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module (in/out). @@ -354,6 +401,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + CS%new_sponges = .true. CS%nz = G%ke CS%isc = G%isc ; CS%iec = G%iec ; CS%jsc = G%jsc ; CS%jec = G%jec CS%isd = G%isd ; CS%ied = G%ied ; CS%jsd = G%jsd ; CS%jed = G%jed @@ -368,11 +416,9 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) if (CS%num_col > 0) then - allocate(CS%Iresttime_col(CS%num_col)) ; CS%Iresttime_col = 0.0 allocate(CS%col_i(CS%num_col)) ; CS%col_i = 0 allocate(CS%col_j(CS%num_col)) ; CS%col_j = 0 - ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -382,9 +428,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) col = col +1 endif enddo ; enddo - - CS%new_sponges = .true. - endif total_sponge_cols = CS%num_col @@ -407,7 +450,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & CS%num_col_u = CS%num_col_u + 1 - enddo; enddo + enddo ; enddo if (CS%num_col_u > 0) then @@ -439,7 +482,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, param_file, CS) Iresttime_v(i,J) = 0.5 * (Iresttime(i,j) + Iresttime(i,j+1)) if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & CS%num_col_v = CS%num_col_v + 1 - enddo; enddo + enddo ; enddo if (CS%num_col_v > 0) then @@ -481,12 +524,14 @@ subroutine init_ALE_sponge_diags(Time, G, diag, CS) end subroutine init_ALE_sponge_diags !> This subroutine stores the reference profile at h points for the variable -! whose address is given by f_ptr. +!! whose address is given by f_ptr. subroutine set_up_ALE_sponge_field_fixed(sp_val, G, f_ptr, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure (in). - type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). - real, dimension(SZI_(G),SZJ_(G),CS%nz_data), intent(in) :: sp_val !< Field to be used in the sponge, it has arbritary number of layers (in). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). + real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & + intent(in) :: sp_val !< Field to be used in the sponge, it has arbritary number of layers. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + target, intent(in) :: f_ptr !< Pointer to the field to be damped integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -518,12 +563,13 @@ end subroutine set_up_ALE_sponge_field_fixed !> This subroutine stores the reference profile at h points for the variable ! whose address is given by filename and fieldname. subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, CS) - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: fieldname - type(time_type), intent(in) :: Time - type(ocean_grid_type), intent(in) :: G !< Grid structure (in). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). - type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). + character(len=*), intent(in) :: filename + character(len=*), intent(in) :: fieldname + type(time_type), intent(in) :: Time + type(ocean_grid_type), intent(in) :: G !< Grid structure (in). + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). + type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). real, allocatable, dimension(:,:,:) :: sp_val !< Field to be used in the sponge real, allocatable, dimension(:,:,:) :: mask_z !< Field mask for the sponge data @@ -613,7 +659,8 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, if (hsrc(k)>0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(col),CS%col_j(col)) ) ! In case data is deeper than model + ! In case data is deeper than model + hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(col),CS%col_j(col)) ) CS%Ref_val(CS%fldno)%h(1:nz_data,col) = 0. CS%Ref_val(CS%fldno)%p(1:nz_data,col) = -1.e24 CS%Ref_val(CS%fldno)%h(1:nz_data,col) = hsrc(1:nz_data) @@ -628,15 +675,17 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, f_ptr, end subroutine set_up_ALE_sponge_field_varying -!> This subroutine stores the reference profile at uand v points for the variable -! whose address is given by u_ptr and v_ptr. +!> This subroutine stores the reference profile at u and v points for the variable +!! whose address is given by u_ptr and v_ptr. subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure (in). - type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). - real, dimension(SZIB_(G),SZJ_(G),CS%nz_data), intent(in) :: u_val !< u field to be used in the sponge, it has arbritary number of layers (in). - real, dimension(SZI_(G),SZJB_(G),CS%nz_data), intent(in) :: v_val !< u field to be used in the sponge, it has arbritary number of layers (in). - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(in) :: u_ptr !< u pointer to the field to be damped (in). - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(in) :: v_ptr !< v pointer to the field to be damped (in). + type(ocean_grid_type), intent(in) :: G !< Grid structure (in). + type(ALE_sponge_CS), pointer :: CS !< Sponge structure (in/out). + real, dimension(SZIB_(G),SZJ_(G),CS%nz_data), & + intent(in) :: u_val !< u field to be used in the sponge, it has arbritary number of layers. + real, dimension(SZI_(G),SZJB_(G),CS%nz_data), & + intent(in) :: v_val !< v field to be used in the sponge, it has arbritary number of layers. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), target, intent(in) :: u_ptr !< u pointer to the field to be damped + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), target, intent(in) :: v_ptr !< v pointer to the field to be damped integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -667,7 +716,7 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, u_ptr, v_ptr, CS) end subroutine set_up_ALE_sponge_vel_field_fixed !> This subroutine stores the reference profile at uand v points for the variable -! whose address is given by u_ptr and v_ptr. +!! whose address is given by u_ptr and v_ptr. subroutine set_up_ALE_sponge_vel_field_varying(filename_u,fieldname_u,filename_v,fieldname_v, Time, G, CS, u_ptr, v_ptr) character(len=*), intent(in) :: filename_u !< File name for u field character(len=*), intent(in) :: fieldname_u !< Name of u variable in file @@ -762,23 +811,26 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u,fieldname_u,filename_v end subroutine set_up_ALE_sponge_vel_field_varying -!> This subroutine applies damping to the layers thicknesses, temp, salt and a variety of tracers for every column where there is damping. +!> This subroutine applies damping to the layers thicknesses, temp, salt and a variety of tracers +!! for every column where there is damping. subroutine apply_ALE_sponge(h, dt, G, CS, Time) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (in). - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness, in m (in) - real, intent(in) :: dt !< The amount of time covered by this call, in s (in). - type(ALE_sponge_CS), pointer :: CS ! A temporary array for h at u pts - real :: hv(SZI_(G), SZJB_(G), SZK_(G)) !> A temporary array for h at v pts - real, allocatable, dimension(:,:,:) :: sp_val !> A temporary array for fields - real, allocatable, dimension(:,:,:) :: mask_z !> A temporary array for field mask at h pts + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< Layer thickness, in m (in) + real, intent(in) :: dt !< The amount of time covered by this call, in s (in). + type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure for this module + !! that is set by a previous call to initialize_sponge (in). + type(time_type), optional, intent(in) :: Time !< The current model date + + real :: damp ! The timestep times the local damping coefficient. ND. + real :: I1pdamp ! I1pdamp is 1/(1 + damp). Nondimensional. + real :: Idt ! 1.0/dt, in s-1. + real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid + real, dimension(SZK_(G)) :: tmp_val1 ! data values remapped to model grid + real :: hu(SZIB_(G), SZJ_(G), SZK_(G)) ! A temporary array for h at u pts + real :: hv(SZI_(G), SZJB_(G), SZK_(G)) ! A temporary array for h at v pts + real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields + real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz, nz_data real, allocatable, dimension(:), target :: z_in, z_edges_in real :: missing_value @@ -801,8 +853,7 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) mask_z(:,:,:)=0.0 call horiz_interp_and_extrap_tracer(CS%Ref_val(CS%fldno)%id,Time, 1.0,G,sp_val,mask_z,z_in,z_edges_in,& - missing_value,.true.,& - .false.,.false.) + missing_value,.true., .false.,.false.) ! call pass_var(sp_val,G%Domain) ! call pass_var(mask_z,G%Domain) @@ -813,9 +864,10 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) do k=2,nz_data ! if (mask_z(i,j,k)==0.) & - if (CS%Ref_val(m)%h(k,c) <= 0.001) & ! some confusion here about why the masks are not correct returning from horiz_interp - ! reverting to using a minimum thickness criteria - CS%Ref_val(m)%p(k,c)=CS%Ref_val(m)%p(k-1,c) + if (CS%Ref_val(m)%h(k,c) <= 0.001) & + ! some confusion here about why the masks are not correct returning from horiz_interp + ! reverting to using a minimum thickness criteria + CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) enddo enddo @@ -825,10 +877,8 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) nz_data = CS%nz_data endif - allocate(tmp_val2(nz_data)) - do m=1,CS%fldno do c=1,CS%num_col ! c is an index for the next 3 lines but a multiplier for the rest of the loop @@ -863,7 +913,7 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) ! u points do j=CS%jsc,CS%jec; do I=CS%iscB,CS%iecB; do k=1,nz hu(I,j,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo if (CS%new_sponges) then if (.not. present(Time)) & @@ -909,7 +959,6 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) deallocate (sp_val, mask_z) - else nz_data = CS%nz_data endif @@ -936,7 +985,7 @@ subroutine apply_ALE_sponge(h, dt, G, CS, Time) ! v points do J=CS%jscB,CS%jecB; do i=CS%isc,CS%iec; do k=1,nz hv(i,J,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo do c=1,CS%num_col_v i = CS%col_i_v(c) ; j = CS%col_j_v(c) diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 similarity index 64% rename from src/parameterizations/vertical/MOM_KPP.F90 rename to src/parameterizations/vertical/MOM_CVMix_KPP.F90 index e479460ebe..59844ea7ad 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1,18 +1,20 @@ !> Provides the K-Profile Parameterization (KPP) of Large et al., 1994, via CVMix. -module MOM_KPP +module MOM_CVMix_KPP ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : max_across_PEs -use MOM_debugging, only : hchksum, is_NaN -use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data -use MOM_diag_mediator, only : query_averaging_enabled, register_diag_field -use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_PE -use MOM_EOS, only : EOS_type, calculate_density -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_file_parser, only : openParameterBlock, closeParameterBlock -use MOM_grid, only : ocean_grid_type, isPointInCell -use MOM_verticalGrid, only : verticalGrid_type +use MOM_coms, only : max_across_PEs +use MOM_debugging, only : hchksum, is_NaN +use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_ptr, post_data +use MOM_diag_mediator, only : query_averaging_enabled, register_diag_field +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_PE +use MOM_EOS, only : EOS_type, calculate_density +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_grid, only : ocean_grid_type, isPointInCell +use MOM_verticalGrid, only : verticalGrid_type +use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number +use MOM_domains, only : pass_var use CVMix_kpp, only : CVMix_init_kpp, CVMix_put_kpp, CVMix_get_kpp_real use CVMix_kpp, only : CVMix_coeffs_kpp @@ -40,11 +42,26 @@ module MOM_KPP integer, private, parameter :: NLT_SHAPE_LINEAR = 1 !< Linear, \f$ G(\sigma) = 1-\sigma \f$ integer, private, parameter :: NLT_SHAPE_PARABOLIC = 2 !< Parabolic, \f$ G(\sigma) = (1-\sigma)^2 \f$ integer, private, parameter :: NLT_SHAPE_CUBIC = 3 !< Cubic, \f$ G(\sigma) = 1 + (2\sigma-3) \sigma^2\f$ -integer, private, parameter :: NLT_SHAPE_CUBIC_LMD = 4 !< Original shape, \f$ G(\sigma) = \frac{27}{4} \sigma (1-\sigma)^2 \f$ +integer, private, parameter :: NLT_SHAPE_CUBIC_LMD = 4 !< Original shape, + !! \f$ G(\sigma) = \frac{27}{4} \sigma (1-\sigma)^2 \f$ integer, private, parameter :: SW_METHOD_ALL_SW = 0 !< Use all shortwave radiation integer, private, parameter :: SW_METHOD_MXL_SW = 1 !< Use shortwave radiation absorbed in mixing layer integer, private, parameter :: SW_METHOD_LV1_SW = 2 !< Use shortwave radiation absorbed in layer 1 +integer, private, parameter :: LT_K_CONSTANT = 1, & !< Constant enhance K through column + LT_K_SCALED = 2, & !< Enhance K scales with G(sigma) + LT_K_MODE_CONSTANT = 1, & !< Prescribed enhancement for K + LT_K_MODE_VR12 = 2, & !< Enhancement for K based on + !! Van Roekel et al., 2012 + LT_K_MODE_RW16 = 3, & !< Enhancement for K based on + !! Reichl et al., 2016 + LT_VT2_MODE_CONSTANT = 1, & !< Prescribed enhancement for Vt2 + LT_VT2_MODE_VR12 = 2, & !< Enhancement for Vt2 based on + !! Van Roekel et al., 2012 + LT_VT2_MODE_RW16 = 3, & !< Enhancement for Vt2 based on + !! Reichl et al., 2016 + LT_VT2_MODE_LF17 = 4 !< Enhancement for Vt2 based on + !! Li and Fox-Kemper, 2017 !> Control structure for containing KPP parameters/data type, public :: KPP_CS ; private @@ -56,11 +73,13 @@ module MOM_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 in determining OBL depth + 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 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 - real :: deepOBLoffset !< If non-zero, is a distance from the bottom that the OBL can not penetrate through (m) + real :: deepOBLoffset !< If non-zero, is a distance from the bottom that the OBL can not + !! penetrate through (m) real :: minOBLdepth !< If non-zero, is a minimum depth for the OBL (m) real :: surf_layer_ext !< Fraction of OBL depth considered in the surface layer (nondim) real :: minVtsqr !< Min for the squared unresolved velocity used in Rib CVMix calculation (m2/s2) @@ -70,16 +89,29 @@ module MOM_KPP character(len=30) :: MatchTechnique !< Method used in CVMix for setting diffusivity and NLT profile functions integer :: NLT_shape !< MOM6 over-ride of CVMix NLT shape function logical :: applyNonLocalTrans !< If True, apply non-local transport to heat and scalars - logical :: smoothBLD !< If True, apply a 1-1-4-1-1 Laplacian filter one time on HBLT. - logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero; for testing purposes. + integer :: n_smooth !< Number of times smoothing operator is applied on OBLdepth. + logical :: deepen_only !< If true, apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper. + logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero + !! for testing purposes. logical :: KPPisAdditive !< If True, will add KPP diffusivity to initial diffusivity. - !! If False, will replace initial diffusivity wherever KPP diffusivity is non-zero. - real :: min_thickness !< A minimum thickness used to avoid division by small numbers in the vicinity of vanished layers. + !! If False, will replace initial diffusivity wherever KPP diffusivity + !! is non-zero. + real :: min_thickness !< A minimum thickness used to avoid division by small numbers + !! in the vicinity of vanished layers. ! smg: obsolete below logical :: correctSurfLayerAvg !< If true, applies a correction to the averaging of surface layer properties real :: surfLayerDepth !< A guess at the depth of the surface layer (which should 0.1 of OBLdepth) (m) ! smg: obsolete above - integer :: SW_METHOD ! CVMix parameters type(CVMix_kpp_params_type), pointer :: KPP_params => NULL() @@ -103,10 +135,14 @@ module MOM_KPP integer :: id_NLT_dTdt = -1 integer :: id_NLT_temp_budget = -1 integer :: id_NLT_saln_budget = -1 + integer :: id_EnhK = -1, id_EnhW = -1, id_EnhVt2 = -1 + integer :: id_OBLdepth_original = -1 ! Diagnostics arrays real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of OBL (m) + real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL (m) without smoothing real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent + real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL (m) real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density (kg/m3) real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity (m2/s2) real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer (dimensionless) @@ -122,6 +158,10 @@ module MOM_KPP real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer (ppt) real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer (m/s) real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer (m/s) + real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient + real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 + + end type KPP_CS @@ -133,7 +173,7 @@ module MOM_KPP !> Initialize the CVMix KPP module and set up diagnostics !! Returns True if KPP is to be used, False otherwise. -logical function KPP_init(paramFile, G, diag, Time, CS, passive) +logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) ! Arguments type(param_file_type), intent(in) :: paramFile !< File parser @@ -141,15 +181,17 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) type(diag_ctrl), target, intent(in) :: diag !< Diagnostics type(time_type), intent(in) :: Time !< Time type(KPP_CS), pointer :: CS !< Control structure - logical, optional, intent(out) :: passive !< Copy of %passiveMode + logical, optional, intent(out) :: passive !< Copy of %passiveMode + type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS ! Local variables #include "version_variable.h" - character(len=40) :: mdl = 'MOM_KPP' ! name of this module - character(len=20) :: string ! local temporary string - logical :: CS_IS_ONE=.false. - - if (associated(CS)) call MOM_error(FATAL, 'MOM_KPP, KPP_init: '// & + character(len=40) :: mdl = 'MOM_CVMix_KPP' !< name of this module + character(len=20) :: string !< local temporary string + 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 + if (associated(CS)) call MOM_error(FATAL, 'MOM_CVMix_KPP, KPP_init: '// & 'Control structure has already been initialized') allocate(CS) @@ -167,6 +209,8 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) call get_param(paramFile, mdl, 'PASSIVE', CS%passiveMode, & 'If True, puts KPP into a passive-diagnostic mode.', & default=.False.) + !BGR: Note using PASSIVE for KPP creates warning for PASSIVE from Convection + ! should we create a separate flag? if (present(passive)) passive=CS%passiveMode ! This is passed back to the caller so ! the caller knows to not use KPP output call get_param(paramFile, mdl, 'APPLY_NONLOCAL_TRANSPORT', CS%applyNonLocalTrans, & @@ -174,10 +218,16 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) 'If False, calculates the non-local transport and tendencies but\n'//& 'purely for diagnostic purposes.', & default=.not. CS%passiveMode) - call get_param(paramFile, mdl, 'SMOOTH_BLD', CS%smoothBLD, & - 'If True, applies a 1-1-4-1-1 Laplacian filter one time on HBLT.\n'// & - 'computed via CVMix to reduce any horizontal two-grid-point noise.', & - default=.false.) + call get_param(paramFile, mdl, 'N_SMOOTH', CS%n_smooth, & + 'The number of times the 1-1-4-1-1 Laplacian filter is applied on\n'// & + 'OBL depth.', & + default=0) + if (CS%n_smooth > 0) then + call get_param(paramFile, mdl, 'DEEPEN_ONLY_VIA_SMOOTHING', CS%deepen_only, & + 'If true, apply OBLdepth smoothing at a cell only if the OBLdepth.\n'// & + 'gets deeper via smoothing.', & + default=.false.) + endif call get_param(paramFile, mdl, 'RI_CRIT', CS%Ri_crit, & 'Critical bulk Richardson number used to define depth of the\n'// & 'surface Ocean Boundary Layer (OBL).', & @@ -191,7 +241,11 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) call get_param(paramFile, mdl, 'INTERP_TYPE', CS%interpType, & 'Type of interpolation to determine the OBL depth.\n'// & 'Allowed types are: linear, quadratic, cubic.', & - default='cubic') + default='quadratic') + call get_param(paramFile, mdl, 'INTERP_TYPE2', CS%interpType2, & + 'Type of interpolation to compute diff and visc at OBL_depth.\n'// & + 'Allowed types are: linear, quadratic, cubic or LMD94.', & + default='LMD94') call get_param(paramFile, mdl, 'COMPUTE_EKMAN', CS%computeEkman, & 'If True, limit OBL depth to be no deeper than Ekman depth.', & default=.False.) @@ -235,6 +289,9 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) call get_param(paramFile, mdl, 'CORRECT_SURFACE_LAYER_AVERAGE', CS%correctSurfLayerAvg, & 'If true, applies a correction step to the averaging of surface layer\n'// & 'properties. This option is obsolete.', default=.False.) + if (CS%correctSurfLayerAvg) & + call MOM_error(FATAL,'Correct surface layer average disabled in code. To recover \n'// & + ' feature will require code intervention.') call get_param(paramFile, mdl, 'FIRST_GUESS_SURFACE_LAYER_DEPTH', CS%surfLayerDepth, & 'The first guess at the depth of the surface layer used for averaging\n'// & 'the surface layer properties. If =0, the top model level properties\n'// & @@ -268,11 +325,24 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) '\t MatchBoth = match gradient for both diffusivity and NLT\n'// & '\t ParabolicNonLocal = sigma*(1-sigma)^2 for diffusivity; (1-sigma)^2 for NLT', & default='SimpleShapes') - if (CS%MatchTechnique.eq.'ParabolicNonLocal') then + if (CS%MatchTechnique == 'ParabolicNonLocal') then ! This forces Cs2 (Cs in non-local computation) to equal 1 for parabolic non-local option. ! May be used during CVMix initialization. Cs_is_one=.true. endif + if (CS%MatchTechnique == 'ParabolicNonLocal' .or. CS%MatchTechnique == 'SimpleShapes') then + ! if gradient won't be matched, lnoDGat1=.true. + lnoDGat1=.true. + endif + + ! safety check to avoid negative diff/visc + if (CS%MatchTechnique == 'MatchBoth' .and. (CS%interpType2 == 'cubic' .or. & + CS%interpType2 == 'quadratic')) then + call MOM_error(FATAL,"If MATCH_TECHNIQUE=MatchBoth, INTERP_TYPE2 must be set to \n"//& + "linear or LMD94 (recommended) to avoid negative viscosity and diffusivity.\n"//& + "Please select one of these valid options." ) + endif + call get_param(paramFile, mdl, 'KPP_ZERO_DIFFUSIVITY', CS%KPPzeroDiffusivity, & 'If True, zeroes the KPP diffusivity and viscosity; for testing purpose.',& default=.False.) @@ -299,6 +369,75 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) 'of vanished layers. This is independent of MIN_THICKNESS used in other parts of MOM.', & units='m', default=0.) +!/BGR: New options for including Langmuir effects +!/ 1. Options related to enhancing the mixing coefficient + call get_param(paramFile, mdl, "USE_KPP_LT_K", CS%LT_K_Enhancement, & + 'Flag for Langmuir turbulence enhancement of turbulent'//& + 'mixing coefficient.', units="", Default=.false.) + call get_param(paramFile, mdl, "STOKES_MIXING", CS%STOKES_MIXING, & + 'Flag for Langmuir turbulence enhancement of turbulent'//& + 'mixing coefficient.', units="", Default=.false.) + if (CS%LT_K_Enhancement) then + call get_param(paramFile, mdl, 'KPP_LT_K_SHAPE', string, & + 'Vertical dependence of LT enhancement of mixing. \n'// & + 'Valid options are: \n'// & + '\t CONSTANT = Constant value for full OBL\n'// & + '\t SCALED = Varies based on normalized shape function.', & + default='CONSTANT') + select case ( trim(string)) + case ("CONSTANT") ; CS%LT_K_SHAPE = LT_K_CONSTANT + case ("SCALED") ; CS%LT_K_SHAPE = LT_K_SCALED + case default ; call MOM_error(FATAL,"KPP_init: "//& + "Unrecognized KPP_LT_K_SHAPE option: "//trim(string)) + end select + call get_param(paramFile, mdl, "KPP_LT_K_METHOD", string , & + 'Method to enhance mixing coefficient in KPP. \n'// & + 'Valid options are: \n'// & + '\t CONSTANT = Constant value (KPP_K_ENH_FAC) \n'// & + '\t VR12 = Function of Langmuir number based on VR12\n'// & + '\t RW16 = Function of Langmuir number based on RW16', & + default='CONSTANT') + select case ( trim(string)) + case ("CONSTANT") ; CS%LT_K_METHOD = LT_K_MODE_CONSTANT + case ("VR12") ; CS%LT_K_METHOD = LT_K_MODE_VR12 + case ("RW16") ; CS%LT_K_METHOD = LT_K_MODE_RW16 + case default ; call MOM_error(FATAL,"KPP_init: "//& + "Unrecognized KPP_LT_K_METHOD option: "//trim(string)) + end select + if (CS%LT_K_METHOD==LT_K_MODE_CONSTANT) then + call get_param(paramFile, mdl, "KPP_K_ENH_FAC",CS%KPP_K_ENH_FAC , & + 'Constant value to enhance mixing coefficient in KPP.', & + default=1.0) + endif + endif +!/ 2. Options related to enhancing the unresolved Vt2/entrainment in Rib + call get_param(paramFile, mdl, "USE_KPP_LT_VT2", CS%LT_Vt2_Enhancement, & + 'Flag for Langmuir turbulence enhancement of Vt2'//& + 'in Bulk Richardson Number.', units="", Default=.false.) + if (CS%LT_Vt2_Enhancement) then + call get_param(paramFile, mdl, "KPP_LT_VT2_METHOD",string , & + 'Method to enhance Vt2 in KPP. \n'// & + 'Valid options are: \n'// & + '\t CONSTANT = Constant value (KPP_VT2_ENH_FAC) \n'// & + '\t VR12 = Function of Langmuir number based on VR12\n'// & + '\t RW16 = Function of Langmuir number based on RW16\n'// & + '\t LF17 = Function of Langmuir number based on LF17', & + default='CONSTANT') + select case ( trim(string)) + case ("CONSTANT") ; CS%LT_VT2_METHOD = LT_VT2_MODE_CONSTANT + case ("VR12") ; CS%LT_VT2_METHOD = LT_VT2_MODE_VR12 + case ("RW16") ; CS%LT_VT2_METHOD = LT_VT2_MODE_RW16 + case ("LF17") ; CS%LT_VT2_METHOD = LT_VT2_MODE_LF17 + case default ; call MOM_error(FATAL,"KPP_init: "//& + "Unrecognized KPP_LT_VT2_METHOD option: "//trim(string)) + end select + if (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then + call get_param(paramFile, mdl, "KPP_VT2_ENH_FAC",CS%KPP_VT2_ENH_FAC , & + 'Constant value to enhance VT2 in KPP.', & + default=1.0) + endif + endif + call closeParameterBlock(paramFile) call get_param(paramFile, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -308,11 +447,13 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) vonKarman=CS%vonKarman, & surf_layer_ext=CS%surf_layer_ext, & interp_type=CS%interpType, & + interp_type2=CS%interpType2, & lEkman=CS%computeEkman, & lMonOb=CS%computeMoninObukhov, & MatchTechnique=CS%MatchTechnique, & lenhanced_diff=CS%enhance_diffusion,& lnonzero_surf_nonlocal=Cs_is_one ,& + lnoDGat1=lnoDGat1 ,& CVMix_kpp_params_user=CS%KPP_params ) ! Register diagnostics @@ -324,6 +465,10 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) ! CMOR names are placeholders; must be modified by time period ! for CMOR compliance. Diag manager will be used for omlmax and ! omldamax. + CS%id_OBLdepth_original = register_diag_field('ocean_model', 'KPP_OBLdepth_original', diag%axesT1, Time, & + 'Thickness of the surface Ocean Boundary Layer without smoothing calculated by [CVMix] KPP', 'meter', & + cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & + cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') CS%id_BulkDrho = register_diag_field('ocean_model', 'KPP_BulkDrho', diag%axesTL, Time, & 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', 'kg/m3') CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & @@ -376,12 +521,22 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) 'i-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'm/s') CS%id_Vsurf = register_diag_field('ocean_model', 'KPP_Vsurf', diag%axesCv1, Time, & 'j-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'm/s') + CS%id_EnhK = register_diag_field('ocean_model', 'EnhK', diag%axesTI, Time, & + 'Langmuir number enhancement to K as used by [CVMix] KPP','nondim') + CS%id_EnhVt2 = register_diag_field('ocean_model', 'EnhVt2', diag%axesTL, Time, & + 'Langmuir number enhancement to Vt2 as used by [CVMix] KPP','nondim') + allocate( CS%N( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + CS%N(:,:,:) = 0. allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ) CS%OBLdepth(:,:) = 0. allocate( CS%kOBL( SZI_(G), SZJ_(G) ) ) CS%kOBL(:,:) = 0. + allocate( CS%Vt2( SZI_(G), SZJ_(G), SZK_(G) ) ) + CS%Vt2(:,:,:) = 0. + if (CS%id_OBLdepth_original > 0) allocate( CS%OBLdepth_original( SZI_(G), SZJ_(G) ) ) + allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ) );CS%OBLdepthprev(:,:)=0.0 if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(G) ) ) if (CS%id_BulkDrho > 0) CS%dRho(:,:,:) = 0. if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G), SZK_(G) ) ) @@ -392,12 +547,8 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) if (CS%id_Sigma > 0) CS%sigma(:,:,:) = 0. if (CS%id_Ws > 0) allocate( CS%Ws( SZI_(G), SZJ_(G), SZK_(G) ) ) if (CS%id_Ws > 0) CS%Ws(:,:,:) = 0. - if (CS%id_N > 0) allocate( CS%N( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) - if (CS%id_N > 0) CS%N(:,:,:) = 0. if (CS%id_N2 > 0) allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) if (CS%id_N2 > 0) CS%N2(:,:,:) = 0. - if (CS%id_Vt2 > 0) allocate( CS%Vt2( SZI_(G), SZJ_(G), SZK_(G) ) ) - if (CS%id_Vt2 > 0) CS%Vt2(:,:,:) = 0. if (CS%id_Kt_KPP > 0) allocate( CS%Kt_KPP( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) if (CS%id_Kt_KPP > 0) CS%Kt_KPP(:,:,:) = 0. if (CS%id_Ks_KPP > 0) allocate( CS%Ks_KPP( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) @@ -412,24 +563,320 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive) if (CS%id_Usurf > 0) CS%Usurf(:,:) = 0. if (CS%id_Vsurf > 0) allocate( CS%Vsurf( SZI_(G), SZJB_(G)) ) if (CS%id_Vsurf > 0) CS%Vsurf(:,:) = 0. + if (CS%id_EnhVt2 > 0) allocate( CS%EnhVt2( SZI_(G), SZJ_(G), SZK_(G)) ) + if (CS%id_EnhVt2 > 0) CS%EnhVt2(:,:,:) = 0. + if (CS%id_EnhK > 0) allocate( CS%EnhK( SZI_(G), SZJ_(G), SZK_(G)+1 ) ) + if (CS%id_EnhK > 0) CS%EnhK(:,:,:) = 0. + end function KPP_init +!> KPP vertical diffusivity/viscosity and non-local tracer transport +subroutine KPP_calculate(CS, G, GV, h, uStar, & + buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& + nonLocalTransScalar, Waves) + + ! Arguments + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux (m2/s3) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP (m2/s) + !< (out) Vertical diffusivity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP (m2/s) + !< (out) Vertical diffusivity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP (m2/s) + !< (out) Vertical viscosity including KPP (m2/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport (m/s) + +! Local variables + integer :: i, j, k ! Loop indices + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) + real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces (m2/s) + real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces (m2/s) + real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) + + real :: surfFricVel, surfBuoyFlux + real :: sigma, sigmaRatio + real :: dh ! The local thickness used for calculating interface positions (m) + real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) + + ! For Langmuir Calculations + real :: LangEnhK ! Langmuir enhancement for mixing coefficient + + +#ifdef __DO_SAFETY_CHECKS__ + if (CS%debug) then + call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0) + call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0) + call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0) + call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0) + endif +#endif + + nonLocalTrans(:,:) = 0.0 + + if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) + + !$OMP parallel do default(private) firstprivate(nonLocalTrans) & + !$OMP shared(G,GV,CS,uStar,h,Waves,& + !$OMP buoyFlux,nonLocalTransHeat,nonLocalTransScalar,Kt,Ks,Kv) + ! loop over horizontal points on processor + do j = G%jsc, G%jec + do i = G%isc, G%iec + + ! skip calling KPP for land points + if (G%mask2dT(i,j)==0.) cycle + + ! things independent of position within the column + surfFricVel = uStar(i,j) + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,G%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + + enddo ! k-loop finishes + + surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit + ! h to Monin-Obukov (default is false, ie. not used) + + ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports + + ! Unlike LMD94, we do not match to interior diffusivities. If using the original + ! LMD94 shape function, not matching is equivalent to matching to a zero diffusivity. + + !BGR/ Add option for use of surface buoyancy flux with total sw flux. + if (CS%SW_METHOD == SW_METHOD_ALL_SW) then + surfBuoyFlux = buoyFlux(i,j,1) + elseif (CS%SW_METHOD == SW_METHOD_MXL_SW) then + surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(CS%kOBL(i,j))+1) ! We know the actual buoyancy flux into the OBL + elseif (CS%SW_METHOD == SW_METHOD_LV1_SW) then + surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,2) + endif + + ! If option "MatchBoth" is selected in CVMix, MOM should be capable of matching. + if (.not. (CS%MatchTechnique == 'MatchBoth')) then + Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt (m2/s) + Kviscosity(:) = 0. ! Viscosity (m2/s) + else + Kdiffusivity(:,1) = Kt(i,j,:) + Kdiffusivity(:,2) = Ks(i,j,:) + Kviscosity(:)=Kv(i,j,:) + endif + + call CVMix_coeffs_kpp(Kviscosity(:), & ! (inout) Total viscosity (m2/s) + Kdiffusivity(:,1), & ! (inout) Total heat diffusivity (m2/s) + Kdiffusivity(:,2), & ! (inout) Total salt diffusivity (m2/s) + iFaceHeight, & ! (in) Height of interfaces (m) + cellHeight, & ! (in) Height of level centers (m) + Kviscosity(:), & ! (in) Original viscosity (m2/s) + Kdiffusivity(:,1), & ! (in) Original heat diffusivity (m2/s) + Kdiffusivity(:,2), & ! (in) Original salt diffusivity (m2/s) + CS%OBLdepth(i,j), & ! (in) OBL depth (m) + CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent + nonLocalTrans(:,1),& ! (out) Non-local heat transport (non-dimensional) + nonLocalTrans(:,2),& ! (out) Non-local salt transport (non-dimensional) + surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + G%ke, & ! (in) Number of levels to compute coeffs for + G%ke, & ! (in) Number of levels in array shape + CVMix_kpp_params_user=CS%KPP_params ) + + ! safety check, Kviscosity and Kdiffusivity must be >= 0 + do k=1, G%ke+1 + if (Kviscosity(k) < 0. .or. Kdiffusivity(k,1) < 0.) then + call MOM_error(FATAL,"KPP_calculate, after CVMix_coeffs_kpp: "// & + "Negative vertical viscosity or diffusivity has been detected. " // & + "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2." //& + "You might consider using the default options for these parameters." ) + endif + enddo + + IF (CS%LT_K_ENHANCEMENT) then + if (CS%LT_K_METHOD==LT_K_MODE_CONSTANT) then + LangEnhK = CS%KPP_K_ENH_FAC + elseif (CS%LT_K_METHOD==LT_K_MODE_VR12) then + LangEnhK = min(10.,sqrt(1.+(1.5*WAVES%LangNum(i,j))**(-2) + & + (5.4*WAVES%LangNum(i,j))**(-4))) + elseif (CS%LT_K_METHOD==LT_K_MODE_RW16) then + LangEnhK = min(2.25, 1. + 1./WAVES%LangNum(i,j)) + else + !This shouldn't be reached. + !call MOM_error(WARNING,"Unexpected behavior in MOM_CVMix_KPP, see error in LT_K_ENHANCEMENT") + LangEnhK = 1.0 + endif + do k=1,G%ke + if (CS%LT_K_SHAPE== LT_K_CONSTANT) then + if (CS%id_EnhK > 0) CS%EnhK(i,j,:) = LangEnhK + Kdiffusivity(k,1) = Kdiffusivity(k,1) * LangEnhK + Kdiffusivity(k,2) = Kdiffusivity(k,2) * LangEnhK + Kviscosity(k) = Kviscosity(k) * LangEnhK + elseif (CS%LT_K_SHAPE == LT_K_SCALED) then + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + SigmaRatio = sigma * (1. - sigma)**2. / 0.148148037 + if (CS%id_EnhK > 0) CS%EnhK(i,j,k) = (1.0 + (LangEnhK - 1.)*sigmaRatio) + Kdiffusivity(k,1) = Kdiffusivity(k,1) * ( 1. + & + ( LangEnhK - 1.)*sigmaRatio) + Kdiffusivity(k,2) = Kdiffusivity(k,2) * ( 1. + & + ( LangEnhK - 1.)*sigmaRatio) + Kviscosity(k) = Kviscosity(k) * ( 1. + & + ( LangEnhK - 1.)*sigmaRatio) + endif + enddo + endif + + ! Over-write CVMix NLT shape function with one of the following choices. + ! The CVMix code has yet to update for thse options, so we compute in MOM6. + ! Note that nonLocalTrans = Cs * G(sigma) (LMD94 notation), with + ! Cs = 6.32739901508. + ! Start do-loop at k=2, since k=1 is ocean surface (sigma=0) + ! and we do not wish to double-count the surface forcing. + ! Only compute nonlocal transport for 0 <= sigma <= 1. + ! MOM6 recommended shape is the parabolic; it gives deeper boundary layer + ! and no spurious extrema. + if (surfBuoyFlux < 0.0) then + if (CS%NLT_shape == NLT_SHAPE_CUBIC) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then + ! Sanity check (should agree with CVMix result using simple matching) + do k = 2, G%ke + sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) + nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 + nonLocalTrans(k,2) = nonLocalTrans(k,1) + enddo + endif + endif + + ! we apply nonLocalTrans in subroutines + ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln + nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temp + nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln + + ! set the KPP diffusivity and viscosity to zero for testing purposes + if (CS%KPPzeroDiffusivity) then + Kdiffusivity(:,1) = 0.0 + Kdiffusivity(:,2) = 0.0 + Kviscosity(:) = 0.0 + endif + + + ! compute unresolved squared velocity for diagnostics + if (CS%id_Vt2 > 0) then +!BGR Now computing VT2 above so can modify for LT +! therefore, don't repeat this operation here +! CS%Vt2(i,j,:) = CVmix_kpp_compute_unresolved_shear( & +! cellHeight(1:G%ke), & ! Depth of cell center (m) +! ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers (m/s) +! N_iface=CS%N(i,j,:), & ! Buoyancy frequency at interface (1/s) +! CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + endif + + ! Copy 1d data into 3d diagnostic arrays + !/ grabbing obldepth_0d for next time step. + CS%OBLdepthprev(i,j)=CS%OBLdepth(i,j) + if (CS%id_sigma > 0) then + CS%sigma(i,j,:) = 0. + if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight/CS%OBLdepth(i,j) + endif + if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = Kdiffusivity(:,1) + if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = Kdiffusivity(:,2) + if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = Kviscosity(:) + + ! Update output of routine + if (.not. CS%passiveMode) then + if (CS%KPPisAdditive) then + do k=1, G%ke+1 + Kt(i,j,k) = Kt(i,j,k) + Kdiffusivity(k,1) + Ks(i,j,k) = Ks(i,j,k) + Kdiffusivity(k,2) + Kv(i,j,k) = Kv(i,j,k) + Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k)=Kv(i,j,k) + enddo + else ! KPP replaces prior diffusivity when former is non-zero + do k=1, G%ke+1 + if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = Kdiffusivity(k,1) + if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = Kdiffusivity(k,2) + if (Kviscosity(k) /= 0.) Kv(i,j,k) = Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k)=Kv(i,j,k) + enddo + endif + endif + + + ! end of the horizontal do-loops over the vertical columns + enddo ! i + enddo ! j + + +#ifdef __DO_SAFETY_CHECKS__ + if (CS%debug) then + call hchksum(Kt, "KPP out: Kt",G%HI,haloshift=0) + call hchksum(Ks, "KPP out: Ks",G%HI,haloshift=0) + endif +#endif + + ! send diagnostics to post_data + if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) + if (CS%id_OBLdepth_original > 0) call post_data(CS%id_OBLdepth_original,CS%OBLdepth_original,CS%diag) + if (CS%id_sigma > 0) call post_data(CS%id_sigma, CS%sigma, CS%diag) + if (CS%id_Ws > 0) call post_data(CS%id_Ws, CS%Ws, CS%diag) + if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) + if (CS%id_uStar > 0) call post_data(CS%id_uStar, uStar, CS%diag) + if (CS%id_buoyFlux > 0) call post_data(CS%id_buoyFlux, buoyFlux, CS%diag) + if (CS%id_Kt_KPP > 0) call post_data(CS%id_Kt_KPP, CS%Kt_KPP, CS%diag) + if (CS%id_Ks_KPP > 0) call post_data(CS%id_Ks_KPP, CS%Ks_KPP, CS%diag) + if (CS%id_Kv_KPP > 0) call post_data(CS%id_Kv_KPP, CS%Kv_KPP, CS%diag) + if (CS%id_NLTt > 0) call post_data(CS%id_NLTt, nonLocalTransHeat, CS%diag) + if (CS%id_NLTs > 0) call post_data(CS%id_NLTs, nonLocalTransScalar,CS%diag) + + +end subroutine KPP_calculate + !> Compute OBL depth -subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) +subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux, Waves) ! Arguments - type(KPP_CS), pointer :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< potential/cons temp (deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity (ppt) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component (m/s) - type(EOS_type), pointer :: EOS !< Equation of state - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) + type(KPP_CS), pointer :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(wave_parameters_CS), optional, pointer :: Waves !< Wave CS + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< potential/cons temp (deg C) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity (ppt) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component (m/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component (m/s) + type(EOS_type), pointer :: EOS !< Equation of state + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux (m2/s3) ! Local variables @@ -437,13 +884,9 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces (1/s2) - real, dimension( G%ke+1 ) :: N_1d ! Brunt-Vaisala frequency at interfaces (1/s) (floored at 0) real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars (m/s) - !real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) - real, dimension( G%ke ) :: Vt2_1d ! Unresolved velocity for bulk Ri calculation/diagnostic (m2/s2) real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri (m2/s2) - real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) real, dimension( G%ke ) :: surfBuoyFlux2 real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer @@ -454,7 +897,7 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) real, dimension( 3*G%ke ) :: Salt_1D real :: surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma + real :: GoRho, pRef, rho1, rhoK, Uk, Vk, sigma, sigmaRatio real :: zBottomMinusOffset ! Height of bottom plus a little bit (m) real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. @@ -468,21 +911,32 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) integer :: kk, ksfc, ktmp + ! For Langmuir Calculations + real :: LangEnhW ! Langmuir enhancement for turbulent velocity scale + real, dimension(G%ke) :: LangEnhVt2 ! Langmuir enhancement for unresolved shear + real, dimension(G%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 + integer :: B + real :: WST + + +#ifdef __DO_SAFETY_CHECKS__ + if (CS%debug) then + call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) + call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) + call hchksum(u, "KPP in: u",G%HI,haloshift=0) + call hchksum(v, "KPP in: v",G%HI,haloshift=0) + endif +#endif + ! some constants GoRho = GV%g_Earth / GV%Rho0 - nonLocalTrans(:,:) = 0.0 -!$OMP parallel do default(none) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & -!$OMP buoyFlux) & -!$OMP private(Coriolis,surfFricVel,SLdepth_0d,hTot,surfTemp, & -!$OMP surfHtemp,surfSalt,surfHsalt,surfU, & -!$OMP surfHu,surfV,surfHv,iFaceHeight, & -!$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & -!$OMP rho1,rhoK,deltaRho,N2_1d,N_1d,delH, & -!$OMP surfBuoyFlux,Ws_1d,BulkRi_1d, & -!$OMP zBottomMinusOffset, & -!$OMP sigma,kk,pres_1D,Temp_1D, & -!$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) +!$OMP parallel do default(private) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & +!$OMP Waves,buoyFlux) & ! loop over horizontal points on processor do j = G%jsc, G%jec @@ -491,6 +945,11 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) ! skip calling KPP for land points if (G%mask2dT(i,j)==0.) cycle + do k=1,G%ke + U_H(k) = 0.5 * (U(i,j,k)+U(i-1,j,k)) + V_H(k) = 0.5 * (V(i,j,k)+V(i,j-1,k)) + enddo + ! things independent of position within the column Coriolis = 0.25*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) & +(G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) @@ -531,6 +990,8 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) surfHsalt=0.0 surfHu =0.0 surfHv =0.0 + surfHuS =0.0 + surfHvS =0.0 hTot =0.0 do ktmp = 1,ksfc @@ -545,18 +1006,33 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + if (CS%Stokes_Mixing) then + surfHus = surfHus + 0.5*(WAVES%US_x(i,j,ktmp)+WAVES%US_x(i-1,j,ktmp)) * delH + surfHvs = surfHvs + 0.5*(WAVES%US_y(i,j,ktmp)+WAVES%US_y(i,j-1,ktmp)) * delH + endif enddo surfTemp = surfHtemp / hTot surfSalt = surfHsalt / hTot surfU = surfHu / hTot surfV = surfHv / hTot + surfUs = surfHus / hTot + surfVs = surfHvs / hTot ! vertical shear between present layer and ! surface layer averaged surfU,surfV. ! C-grid average to get Uk and Vk on T-points. Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + + if (CS%Stokes_Mixing) then + ! If momentum is mixed down the Stokes drift gradient, then + ! the Stokes drift must be included in the bulk Richardson number + ! calculation. + Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) -surfUs ) + Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) -surfVs ) + endif + deltaU2(k) = Uk**2 + Vk**2 ! pressure, temp, and saln for EOS @@ -584,22 +1060,35 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) enddo ! k-loop finishes + if (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) then + if (.not.(present(WAVES).and.associated(WAVES))) then + call MOM_error(FATAL,"Trying to use input WAVES information in KPP\n"//& + "without activating USEWAVES") + endif + !For now get Langmuir number based on prev. MLD (otherwise must compute 3d LA) + MLD_GUESS = max( 1., abs(CS%OBLdepthprev(i,j) ) ) + call get_Langmuir_Number( LA, G, GV, MLD_guess, surfFricVel, I, J, & + H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) + WAVES%LangNum(i,j)=LA + endif + + ! compute in-situ density call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, 1, 3*G%ke, EOS) ! N2 (can be negative) and N (non-negative) on interfaces. ! deltaRho is non-local rho difference used for bulk Richardson number. - ! N_1d is local N (with floor) used for unresolved shear calculation. + ! CS%N is local N (with floor) used for unresolved shear calculation. do k = 1, G%ke km1 = max(1, k-1) kk = 3*(k-1) deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) N2_1d(k) = (GoRho * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) - N_1d(k) = sqrt( max( N2_1d(k), 0.) ) + CS%N(i,j,k) = sqrt( max( N2_1d(k), 0.) ) enddo N2_1d(G%ke+1 ) = 0.0 - N_1d(G%ke+1 ) = 0.0 + CS%N(i,j,G%ke+1 ) = 0.0 ! turbulent velocity scales w_s and w_m computed at the cell centers. ! Note that if sigma > CS%surf_layer_ext, then CVMix_kpp_compute_turbulent_scales @@ -613,13 +1102,58 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) CVMix_kpp_params_user=CS%KPP_params ) + !Compute CVMix VT2 + CS%Vt2(i,j,:) = CVmix_kpp_compute_unresolved_shear( & + zt_cntr=cellHeight(1:G%ke), & ! Depth of cell center (m) + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers (m/s) + N_iface=CS%N(i,j,:), & ! Buoyancy frequency at interface (1/s) + CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + + !Modify CVMix VT2 + IF (CS%LT_VT2_ENHANCEMENT) then + IF (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then + do k=1,G%ke + LangEnhVT2(k) = CS%KPP_VT2_ENH_FAC + enddo + elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_VR12) then + do k=1,G%ke + LangEnhVT2(k) = min(10.,sqrt(1.+(1.5*WAVES%LangNum(i,j))**(-2) + & + (5.4*WAVES%LangNum(i,j))**(-4))) + enddo + elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_RW16) then + do k=1,G%ke + LangEnhVT2(k) = min(2.25, 1. + 1./WAVES%LangNum(i,j)) + enddo + elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_LF17) then + CS%CS=cvmix_get_kpp_real('c_s',CS%KPP_params) + do k=1,G%ke + WST = (max(0.,-buoyflux(i,j,1))*(-cellHeight(k)))**(1./3.) + LangEnhVT2(k) = sqrt((0.15*WST**3. + 0.17*surfFricVel**3.* & + (1.+0.49*WAVES%LangNum(i,j)**(-2.))) / & + (0.2*ws_1d(k)**3/(CS%cs*CS%surf_layer_ext*CS%vonKarman**4.))) + enddo + else + !This shouldn't be reached. + !call MOM_error(WARNING,"Unexpected behavior in MOM_CVMix_KPP, see error in Vt2") + LangEnhVT2(:) = 1.0 + endif + else + LangEnhVT2(:) = 1.0 + endif + + do k=1,G%ke + CS%Vt2(i,j,k)=CS%Vt2(i,j,k)*LangEnhVT2(k) + if (CS%id_EnhVt2 > 0) CS%EnhVt2(i,j,k)=LangEnhVT2(k) + enddo + ! Calculate Bulk Richardson number from eq (21) of LMD94 - BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & - cellHeight(1:G%ke), & ! Depth of cell center (m) - GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) - deltaU2, & ! Square of resolved velocity difference (m2/s2) + BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & + zt_cntr = cellHeight(1:G%ke), & ! Depth of cell center (m) + delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) + delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference (m2/s2) + Vt_sqr_cntr=CS%Vt2(i,j,:), & ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) - N_iface=N_1d) ! Buoyancy frequency (1/s) + N_iface=CS%N(i,j,:)) ! Buoyancy frequency (1/s) surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit @@ -654,81 +1188,123 @@ subroutine KPP_compute_BLD(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, buoyFlux) ! Following "correction" step has been found to be unnecessary. ! Code should be removed after further testing. - if (CS%correctSurfLayerAvg) then - - SLdepth_0d = CS%surf_layer_ext * CS%OBLdepth(i,j) - hTot = h(i,j,1) - surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot - surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot - surfU = 0.5*(u(i,j,1)+u(i-1,j,1)) ; surfHu = surfU * hTot - surfV = 0.5*(v(i,j,1)+v(i,j-1,1)) ; surfHv = surfV * hTot - pRef = 0.0 - - do k = 2, G%ke - - ! Recalculate differences with surface layer - Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU - Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV - deltaU2(k) = Uk**2 + Vk**2 - pRef = pRef + GV%H_to_Pa * h(i,j,k) - call calculate_density(surfTemp, surfSalt, pRef, rho1, EOS) - call calculate_density(Temp(i,j,k), Salt(i,j,k), pRef, rhoK, EOS) - deltaRho(k) = rhoK - rho1 - - ! Surface layer averaging (needed for next k+1 iteration of this loop) - if (hTot < SLdepth_0d) then - delH = min( max(0., SLdepth_0d - hTot), h(i,j,k)*GV%H_to_m ) - hTot = hTot + delH - surfHtemp = surfHtemp + Temp(i,j,k) * delH ; surfTemp = surfHtemp / hTot - surfHsalt = surfHsalt + Salt(i,j,k) * delH ; surfSalt = surfHsalt / hTot - surfHu = surfHu + 0.5*(u(i,j,k)+u(i-1,j,k)) * delH ; surfU = surfHu / hTot - surfHv = surfHv + 0.5*(v(i,j,k)+v(i,j-1,k)) * delH ; surfV = surfHv / hTot - endif - - enddo - - BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & - cellHeight(1:G%ke), & ! Depth of cell center (m) - GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) - deltaU2, & ! Square of resolved velocity difference (m2/s2) - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) - N_iface=N_1d ) ! Buoyancy frequency (1/s) - - surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit - ! h to Monin-Obukov (default is false, ie. not used) - - call CVMix_kpp_compute_OBL_depth( & - BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces (m) - CS%OBLdepth(i,j), & ! (out) OBL depth (m) - CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers (m) - surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters - - if (CS%deepOBLoffset>0.) then - zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - endif - - ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value - CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deep than bottom - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - - endif ! endif for "correction" step +! BGR: 03/15/2018-> Restructured code (Vt2 changed to compute from call in MOM_CVMix_KPP now) +! I have not taken this restructuring into account here. +! Do we ever run with correctSurfLayerAvg? +! smg's suggested testing and removal is advised, in the meantime +! I have added warning if correctSurfLayerAvg is attempted. + ! if (CS%correctSurfLayerAvg) then + + ! SLdepth_0d = CS%surf_layer_ext * CS%OBLdepth(i,j) + ! hTot = h(i,j,1) + ! surfTemp = Temp(i,j,1) ; surfHtemp = surfTemp * hTot + ! surfSalt = Salt(i,j,1) ; surfHsalt = surfSalt * hTot + ! surfU = 0.5*(u(i,j,1)+u(i-1,j,1)) ; surfHu = surfU * hTot + ! surfV = 0.5*(v(i,j,1)+v(i,j-1,1)) ; surfHv = surfV * hTot + ! pRef = 0.0 + + ! do k = 2, G%ke + + ! ! Recalculate differences with surface layer + ! Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU + ! Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + ! deltaU2(k) = Uk**2 + Vk**2 + ! pRef = pRef + GV%H_to_Pa * h(i,j,k) + ! call calculate_density(surfTemp, surfSalt, pRef, rho1, EOS) + ! call calculate_density(Temp(i,j,k), Salt(i,j,k), pRef, rhoK, EOS) + ! deltaRho(k) = rhoK - rho1 + + ! ! Surface layer averaging (needed for next k+1 iteration of this loop) + ! if (hTot < SLdepth_0d) then + ! delH = min( max(0., SLdepth_0d - hTot), h(i,j,k)*GV%H_to_m ) + ! hTot = hTot + delH + ! surfHtemp = surfHtemp + Temp(i,j,k) * delH ; surfTemp = surfHtemp / hTot + ! surfHsalt = surfHsalt + Salt(i,j,k) * delH ; surfSalt = surfHsalt / hTot + ! surfHu = surfHu + 0.5*(u(i,j,k)+u(i-1,j,k)) * delH ; surfU = surfHu / hTot + ! surfHv = surfHv + 0.5*(v(i,j,k)+v(i,j-1,k)) * delH ; surfV = surfHv / hTot + ! endif + + ! enddo + + ! BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & + ! cellHeight(1:G%ke), & ! Depth of cell center (m) + ! GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) + ! deltaU2, & ! Square of resolved velocity difference (m2/s2) + ! ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) + ! N_iface=CS%N ) ! Buoyancy frequency (1/s) + + ! surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit + ! ! h to Monin-Obukov (default is false, ie. not used) + + ! call CVMix_kpp_compute_OBL_depth( & + ! BulkRi_1d, & ! (in) Bulk Richardson number + ! iFaceHeight, & ! (in) Height of interfaces (m) + ! CS%OBLdepth(i,j), & ! (out) OBL depth (m) + ! CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent + ! zt_cntr=cellHeight, & ! (in) Height of cell centers (m) + ! surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + ! surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + ! Coriolis=Coriolis, & ! (in) Coriolis parameter (1/s) + ! CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + + ! if (CS%deepOBLoffset>0.) then + ! zBottomMinusOffset = iFaceHeight(G%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(G%ke+1)) + ! CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) + ! CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + ! endif + + ! ! apply some constraints on OBLdepth + ! if(CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + ! CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + ! CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deep than bottom + ! CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + + ! endif ! endif for "correction" step ! smg: remove code above ! ********************************************************************** + ! recompute wscale for diagnostics, now that we in fact know boundary layer depth + !BGR consider if LTEnhancement is wanted for diagnostics + if (CS%id_Ws > 0) then + call CVMix_kpp_compute_turbulent_scales( & + -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate + CS%OBLdepth(i,j), & ! (in) OBL depth (m) + surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) + surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) + CVMix_kpp_params_user=CS%KPP_params) ! KPP parameters + CS%Ws(i,j,:) = Ws_1d(:) + endif + + ! Diagnostics + if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) + if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) + if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) + if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) + if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp + if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt + if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU + if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv + enddo enddo - if (CS%smoothBLD) call KPP_smooth_BLD(CS,G,GV,h) + ! send diagnostics to post_data + if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) + if (CS%id_N > 0) call post_data(CS%id_N, CS%N, CS%diag) + if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) + if (CS%id_Tsurf > 0) call post_data(CS%id_Tsurf, CS%Tsurf, CS%diag) + if (CS%id_Ssurf > 0) call post_data(CS%id_Ssurf, CS%Ssurf, CS%diag) + if (CS%id_Usurf > 0) call post_data(CS%id_Usurf, CS%Usurf, CS%diag) + if (CS%id_Vsurf > 0) call post_data(CS%id_Vsurf, CS%Vsurf, CS%diag) + if (CS%id_BulkDrho > 0) call post_data(CS%id_BulkDrho, CS%dRho, CS%diag) + if (CS%id_BulkUz2 > 0) call post_data(CS%id_BulkUz2, CS%Uz2, CS%diag) + if (CS%id_EnhK > 0) call post_data(CS%id_EnhK, CS%EnhK, CS%diag) + if (CS%id_EnhVt2 > 0) call post_data(CS%id_EnhVt2, CS%EnhVt2, CS%diag) + + ! BLD smoothing: + if (CS%n_smooth > 0) call KPP_smooth_BLD(CS,G,GV,h) end subroutine KPP_compute_BLD @@ -742,178 +1318,76 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) ! local - real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) - real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) - integer :: i, j, k - real :: wc, ww, we, wn, ws ! averaging weights for smoothing - real :: dh ! The local thickness used for calculating interface positions (m) - real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_original ! Original OBL depths computed by CVMix + real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) + real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) + real :: wc, ww, we, wn, ws ! averaging weights for smoothing + real :: dh ! The local thickness used for calculating interface positions (m) + real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) + real :: pref + integer :: i, j, k, s - ! apply smoothing on OBL depth - do j = G%jsc, G%jec - do i = G%isc, G%iec + do s=1,CS%n_smooth - ! skip land points - if (G%mask2dT(i,j)==0.) cycle + ! Update halos + call pass_var(CS%OBLdepth, G%Domain) - ! 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) - - CS%OBLdepth(i,j) = wc * CS%OBLdepth(i,j) & - + ww * CS%OBLdepth(i-1,j) & - + we * CS%OBLdepth(i+1,j) & - + ws * CS%OBLdepth(i,j-1) & - + wn * CS%OBLdepth(i,j+1) - enddo - enddo + OBLdepth_original = CS%OBLdepth + if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = OBLdepth_original - ! Update kOBL for smoothed OBL depths - do j = G%jsc, G%jec - do i = G%isc, G%iec + ! apply smoothing on OBL depth + do j = G%jsc, G%jec + do i = G%isc, G%iec - ! skip land points - if (G%mask2dT(i,j)==0.) cycle + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + pRef = 0. + hcorr = 0. + do k=1,G%ke + + ! cell center and cell bottom in meters (negative values in the ocean) + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo - iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - hcorr = 0. - do k=1,G%ke + ! 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) - ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment - dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) - hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh - enddo + CS%OBLdepth(i,j) = wc * OBLdepth_original(i,j) & + + ww * OBLdepth_original(i-1,j) & + + we * OBLdepth_original(i+1,j) & + + ws * OBLdepth_original(i,j-1) & + + wn * OBLdepth_original(i,j+1) - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + ! Apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper via smoothing. + if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j),CS%OBLdepth_original(i,j)) + ! prevent OBL depths deeper than the bathymetric depth + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(G%ke+1) ) ! no deeper than bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + enddo enddo - enddo -end subroutine KPP_smooth_BLD - - -!> KPP vertical diffusivity/viscosity and non-local tracer transport -subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & - buoyFlux, Kt, Ks, Kv, nonLocalTransHeat,& - nonLocalTransScalar) - - ! Arguments - type(KPP_CS), pointer :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thicknesses (units of H) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Temp !< potential/cons temp (deg C) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: Salt !< Salinity (ppt) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Velocity i-component (m/s) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Velocity j-component (m/s) - type(EOS_type), pointer :: EOS !< Equation of state - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: buoyFlux !< Surface buoyancy flux (m2/s3) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP (m2/s) - !< (out) Vertical diffusivity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP (m2/s) - !< (out) Vertical diffusivity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP (m2/s) - !< (out) Vertical viscosity including KPP (m2/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport (m/s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local transport (m/s) + enddo ! s-loop -! Local variables - integer :: i, j, k, km1,kp1 ! Loop indices - real, dimension( G%ke ) :: cellHeight ! Cell center heights referenced to surface (m) (negative in ocean) - real, dimension( G%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface (m) (negative in ocean) - real, dimension( G%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces (1/s2) - real, dimension( G%ke+1 ) :: N_1d ! Brunt-Vaisala frequency at interfaces (1/s) (floored at 0) - real, dimension( G%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars (m/s) - real, dimension( G%ke ) :: Wm_1d ! Profile of vertical velocity scale for momentum (m/s) - real, dimension( G%ke ) :: Vt2_1d ! Unresolved velocity for bulk Ri calculation/diagnostic (m2/s2) - real, dimension( G%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer - real, dimension( G%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number - real, dimension( G%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri (m2/s2) - real, dimension( G%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces (m2/s) - real, dimension( G%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces (m2/s) - real, dimension( G%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces (non-dimensional) - real, dimension( G%ke ) :: surfBuoyFlux2 - - ! for EOS calculation - real, dimension( 3*G%ke ) :: rho_1D - real, dimension( 3*G%ke ) :: pres_1D - real, dimension( 3*G%ke ) :: Temp_1D - real, dimension( 3*G%ke ) :: Salt_1D - - real :: surfFricVel, surfBuoyFlux - real :: GoRho, pRef, rho1, rhoK, rhoKm1, Uk, Vk, sigma - - real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. - real :: hTot ! Running sum of thickness used in the surface layer average (m) - real :: delH ! Thickness of a layer (m) - real :: surfHtemp, surfTemp ! Integral and average of temp over the surface layer - real :: surfHsalt, surfSalt ! Integral and average of saln over the surface layer - real :: surfHu, surfU ! Integral and average of u over the surface layer - real :: surfHv, surfV ! Integral and average of v over the surface layer - real :: dh ! The local thickness used for calculating interface positions (m) - real :: hcorr ! A cumulative correction arising from inflation of vanished layers (m) - integer :: kk, ksfc, ktmp - -#ifdef __DO_SAFETY_CHECKS__ - if (CS%debug) then - call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) - call hchksum(Temp, "KPP in: T",G%HI,haloshift=0) - call hchksum(Salt, "KPP in: S",G%HI,haloshift=0) - call hchksum(u, "KPP in: u",G%HI,haloshift=0) - call hchksum(v, "KPP in: v",G%HI,haloshift=0) - call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0) - call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0) - call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0) - call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0) - endif -#endif - - ! some constants - GoRho = GV%g_Earth / GV%Rho0 - nonLocalTrans(:,:) = 0.0 - - if (CS%id_Kd_in > 0) call post_data(CS%id_Kd_in, Kt, CS%diag) - -!$OMP parallel do default(none) shared(G,GV,CS,EOS,uStar,Temp,Salt,u,v,h,GoRho, & -!$OMP buoyFlux, nonLocalTransHeat, & -!$OMP nonLocalTransScalar,Kt,Ks,Kv) & -!$OMP firstprivate(nonLocalTrans) & -!$OMP private(surfFricVel,SLdepth_0d,hTot,surfTemp, & -!$OMP surfHtemp,surfSalt,surfHsalt,surfU, & -!$OMP surfHu,surfV,surfHv,iFaceHeight, & -!$OMP pRef,km1,cellHeight,Uk,Vk,deltaU2, & -!$OMP rho1,rhoK,rhoKm1,deltaRho,N2_1d,N_1d,delH, & -!$OMP surfBuoyFlux,Ws_1d,Vt2_1d,BulkRi_1d, & -!$OMP Kdiffusivity, & -!$OMP Kviscosity,sigma,kk,pres_1D,Temp_1D, & -!$OMP Salt_1D,rho_1D,surfBuoyFlux2,ksfc,dh,hcorr) - - ! loop over horizontal points on processor + ! Update kOBL for smoothed OBL depths do j = G%jsc, G%jec do i = G%isc, G%iec - ! skip calling KPP for land points + ! skip land points if (G%mask2dT(i,j)==0.) cycle - ! things independent of position within the column - surfFricVel = uStar(i,j) - - ! Bullk Richardson number computed for each cell in a column, - ! assuming OBLdepth = grid cell depth. After Rib(k) is - ! known for the column, then CVMix interpolates to find - ! the actual OBLdepth. This approach avoids need to iterate - ! on the OBLdepth calculation. It follows that used in MOM5 - ! and POP. iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - pRef = 0. hcorr = 0. do k=1,G%ke @@ -924,306 +1398,15 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness cellHeight(k) = iFaceHeight(k) - 0.5 * dh iFaceHeight(k+1) = iFaceHeight(k) - dh - - ! find ksfc for cell where "surface layer" sits - SLdepth_0d = CS%surf_layer_ext*max( max(-cellHeight(k),-iFaceHeight(2) ), CS%minOBLdepth ) - ksfc = k - do ktmp = 1,k - if (-1.0*iFaceHeight(ktmp+1) >= SLdepth_0d) then - ksfc = ktmp - exit - endif - enddo - - ! average temp, saln, u, v over surface layer - ! use C-grid average to get u,v on T-points. - surfHtemp=0.0 - surfHsalt=0.0 - surfHu =0.0 - surfHv =0.0 - hTot =0.0 - do ktmp = 1,ksfc - - ! SLdepth_0d can be between cell interfaces - delH = min( max(0.0, SLdepth_0d - hTot), h(i,j,ktmp)*GV%H_to_m ) - - ! surface layer thickness - hTot = hTot + delH - - ! surface averaged fields - surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH - surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH - surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH - surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH - - enddo - surfTemp = surfHtemp / hTot - surfSalt = surfHsalt / hTot - surfU = surfHu / hTot - surfV = surfHv / hTot - - ! vertical shear between present layer and - ! surface layer averaged surfU,surfV. - ! C-grid average to get Uk and Vk on T-points. - Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU - Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV - deltaU2(k) = Uk**2 + Vk**2 - - ! pressure, temp, and saln for EOS - ! kk+1 = surface fields - ! kk+2 = k fields - ! kk+3 = km1 fields - km1 = max(1, k-1) - kk = 3*(k-1) - pres_1D(kk+1) = pRef - pres_1D(kk+2) = pRef - pres_1D(kk+3) = pRef - Temp_1D(kk+1) = surfTemp - Temp_1D(kk+2) = Temp(i,j,k) - Temp_1D(kk+3) = Temp(i,j,km1) - Salt_1D(kk+1) = surfSalt - Salt_1D(kk+2) = Salt(i,j,k) - Salt_1D(kk+3) = Salt(i,j,km1) - - ! pRef is pressure at interface between k and km1. - ! iterate pRef for next pass through k-loop. - pRef = pRef + GV%H_to_Pa * h(i,j,k) - - ! this difference accounts for penetrating SW - surfBuoyFlux2(k) = buoyFlux(i,j,1) - buoyFlux(i,j,k+1) - - enddo ! k-loop finishes - - ! compute in-situ density - call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, 1, 3*G%ke, EOS) - - ! N2 (can be negative) and N (non-negative) on interfaces. - ! deltaRho is non-local rho difference used for bulk Richardson number. - ! N_1d is local N (with floor) used for unresolved shear calculation. - do k = 1, G%ke - km1 = max(1, k-1) - kk = 3*(k-1) - deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) - N2_1d(k) = (GoRho * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & - ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) - N_1d(k) = sqrt( max( N2_1d(k), 0.) ) enddo - N2_1d(G%ke+1 ) = 0.0 - N_1d(G%ke+1 ) = 0.0 - - ! turbulent velocity scales w_s and w_m computed at the cell centers. - ! Note that if sigma > CS%surf_layer_ext, then CVMix_kpp_compute_turbulent_scales - ! computes w_s and w_m velocity scale at sigma=CS%surf_layer_ext. So we only pass - ! sigma=CS%surf_layer_ext for this calculation. - call CVMix_kpp_compute_turbulent_scales( & - CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext - -cellHeight, & ! (in) Assume here that OBL depth (m) = -cellHeight(k) - surfBuoyFlux2, & ! (in) Buoyancy flux at surface (m2/s3) - surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) - CVMix_kpp_params_user=CS%KPP_params ) - - ! Calculate Bulk Richardson number from eq (21) of LMD94 - BulkRi_1d = CVMix_kpp_compute_bulk_Richardson( & - cellHeight(1:G%ke), & ! Depth of cell center (m) - GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) (1/s) - deltaU2, & ! Square of resolved velocity difference (m2/s2) - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile (m/s) - N_iface=N_1d) ! Buoyancy frequency (1/s) - - - surfBuoyFlux = buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit - ! h to Monin-Obukov (default is false, ie. not used) - - - ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports - - ! Unlike LMD94, we do not match to interior diffusivities. If using the original - ! LMD94 shape function, not matching is equivalent to matching to a zero diffusivity. - !BGR/ Add option for use of surface buoyancy flux with total sw flux. - if (CS%SW_METHOD .eq. SW_METHOD_ALL_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - elseif (CS%SW_METHOD .eq. SW_METHOD_MXL_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(CS%kOBL(i,j))+1) ! We know the actual buoyancy flux into the OBL - elseif (CS%SW_METHOD .eq. SW_METHOD_LV1_SW) then - surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,2) - endif + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - ! If option "MatchBoth" is selected in CVMix, MOM should be capable of matching. - if (.not. (CS%MatchTechnique.eq.'MatchBoth')) then - Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt (m2/s) - Kviscosity(:) = 0. ! Viscosity (m2/s) - else - Kdiffusivity(:,1) = Kt(i,j,:) - Kdiffusivity(:,2) = Ks(i,j,:) - Kviscosity(:)=Kv(i,j,:) - endif - - call CVMix_coeffs_kpp(Kviscosity, & ! (inout) Total viscosity (m2/s) - Kdiffusivity(:,1), & ! (inout) Total heat diffusivity (m2/s) - Kdiffusivity(:,2), & ! (inout) Total salt diffusivity (m2/s) - iFaceHeight, & ! (in) Height of interfaces (m) - cellHeight, & ! (in) Height of level centers (m) - Kviscosity, & ! (in) Original viscosity (m2/s) - Kdiffusivity(:,1), & ! (in) Original heat diffusivity (m2/s) - Kdiffusivity(:,2), & ! (in) Original salt diffusivity (m2/s) - CS%OBLdepth(i,j), & ! (in) OBL depth (m) - CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent - nonLocalTrans(:,1),& ! (out) Non-local heat transport (non-dimensional) - nonLocalTrans(:,2),& ! (out) Non-local salt transport (non-dimensional) - surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - G%ke, & ! (in) Number of levels to compute coeffs for - G%ke, & ! (in) Number of levels in array shape - CVMix_kpp_params_user=CS%KPP_params ) - - - ! Over-write CVMix NLT shape function with one of the following choices. - ! The CVMix code has yet to update for thse options, so we compute in MOM6. - ! Note that nonLocalTrans = Cs * G(sigma) (LMD94 notation), with - ! Cs = 6.32739901508. - ! Start do-loop at k=2, since k=1 is ocean surface (sigma=0) - ! and we do not wish to double-count the surface forcing. - ! Only compute nonlocal transport for 0 <= sigma <= 1. - ! MOM6 recommended shape is the parabolic; it gives deeper boundary layer - ! and no spurious extrema. - if (surfBuoyFlux < 0.0) then - if (CS%NLT_shape == NLT_SHAPE_CUBIC) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) - nonLocalTrans(k,1) = (1.0 - sigma)**2 * (1.0 + 2.0*sigma) !* - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_PARABOLIC) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) - nonLocalTrans(k,1) = (1.0 - sigma)**2 !*CS%CS2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_LINEAR) then - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) - nonLocalTrans(k,1) = (1.0 - sigma)!*CS%CS2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - elseif (CS%NLT_shape == NLT_SHAPE_CUBIC_LMD) then - ! Sanity check (should agree with CVMix result using simple matching) - do k = 2, G%ke - sigma = min(1.0,-iFaceHeight(k)/CS%OBLdepth(i,j)) - nonLocalTrans(k,1) = CS%CS2 * sigma*(1.0 -sigma)**2 - nonLocalTrans(k,2) = nonLocalTrans(k,1) - enddo - endif - endif - - ! we apply nonLocalTrans in subroutines - ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln - nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temp - nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln - - ! set the KPP diffusivity and viscosity to zero for testing purposes - if(CS%KPPzeroDiffusivity) then - Kdiffusivity(:,1) = 0.0 - Kdiffusivity(:,2) = 0.0 - Kviscosity(:) = 0.0 - endif - - ! recompute wscale for diagnostics, now that we in fact know boundary layer depth - if (CS%id_Ws > 0) then - call CVMix_kpp_compute_turbulent_scales( & - -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate - CS%OBLdepth(i,j), & ! (in) OBL depth (m) - surfBuoyFlux, & ! (in) Buoyancy flux at surface (m2/s3) - surfFricVel, & ! (in) Turbulent friction velocity at surface (m/s) - w_s=Ws_1d, & ! (out) Turbulent velocity scale profile (m/s) - CVMix_kpp_params_user=CS%KPP_params & ! KPP parameters - ) - CS%Ws(i,j,:) = Ws_1d(:) - endif - - ! compute unresolved squared velocity for diagnostics - if (CS%id_Vt2 > 0) then - Vt2_1d(:) = CVMix_kpp_compute_unresolved_shear( & - cellHeight(1:G%ke), & ! Depth of cell center (m) - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers (m/s) - N_iface=N_1d, & ! Buoyancy frequency at interface (1/s) - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters - CS%Vt2(i,j,:) = Vt2_1d(:) - endif - - ! Copy 1d data into 3d diagnostic arrays - if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) - if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) - if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) - if (CS%id_sigma > 0) then - CS%sigma(i,j,:) = 0. - if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight/CS%OBLdepth(i,j) - endif - if (CS%id_N > 0) CS%N(i,j,:) = N_1d(:) - if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) - if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = Kdiffusivity(:,1) - if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = Kdiffusivity(:,2) - if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = Kviscosity(:) - if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp - if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt - if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU - if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv - - - ! Update output of routine - if (.not. CS%passiveMode) then - if (CS%KPPisAdditive) then - do k=1, G%ke+1 - Kt(i,j,k) = Kt(i,j,k) + Kdiffusivity(k,1) - Ks(i,j,k) = Ks(i,j,k) + Kdiffusivity(k,2) - Kv(i,j,k) = Kv(i,j,k) + Kviscosity(k) - enddo - else ! KPP replaces prior diffusivity when former is non-zero - do k=1, G%ke+1 - if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = Kdiffusivity(k,1) - if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = Kdiffusivity(k,2) - if (Kviscosity(k) /= 0.) Kv(i,j,k) = Kviscosity(k) - enddo - endif - endif - - - ! end of the horizontal do-loops over the vertical columns - enddo ! i - enddo ! j - - -#ifdef __DO_SAFETY_CHECKS__ - if (CS%debug) then - call hchksum(Kt, "KPP out: Kt",G%HI,haloshift=0) - call hchksum(Ks, "KPP out: Ks",G%HI,haloshift=0) - endif -#endif + enddo + enddo - ! send diagnostics to post_data - if (CS%id_OBLdepth > 0) call post_data(CS%id_OBLdepth, CS%OBLdepth, CS%diag) - if (CS%id_BulkDrho > 0) call post_data(CS%id_BulkDrho, CS%dRho, CS%diag) - if (CS%id_BulkUz2 > 0) call post_data(CS%id_BulkUz2, CS%Uz2, CS%diag) - if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) - if (CS%id_sigma > 0) call post_data(CS%id_sigma, CS%sigma, CS%diag) - if (CS%id_Ws > 0) call post_data(CS%id_Ws, CS%Ws, CS%diag) - if (CS%id_N > 0) call post_data(CS%id_N, CS%N, CS%diag) - if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) - if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) - if (CS%id_uStar > 0) call post_data(CS%id_uStar, uStar, CS%diag) - if (CS%id_buoyFlux > 0) call post_data(CS%id_buoyFlux, buoyFlux, CS%diag) - if (CS%id_Kt_KPP > 0) call post_data(CS%id_Kt_KPP, CS%Kt_KPP, CS%diag) - if (CS%id_Ks_KPP > 0) call post_data(CS%id_Ks_KPP, CS%Ks_KPP, CS%diag) - if (CS%id_Kv_KPP > 0) call post_data(CS%id_Kv_KPP, CS%Kv_KPP, CS%diag) - if (CS%id_NLTt > 0) call post_data(CS%id_NLTt, nonLocalTransHeat, CS%diag) - if (CS%id_NLTs > 0) call post_data(CS%id_NLTs, nonLocalTransScalar,CS%diag) - if (CS%id_Tsurf > 0) call post_data(CS%id_Tsurf, CS%Tsurf, CS%diag) - if (CS%id_Ssurf > 0) call post_data(CS%id_Ssurf, CS%Ssurf, CS%diag) - if (CS%id_Usurf > 0) call post_data(CS%id_Usurf, CS%Usurf, CS%diag) - if (CS%id_Vsurf > 0) call post_data(CS%id_Vsurf, CS%Vsurf, CS%diag) +end subroutine KPP_smooth_BLD -end subroutine KPP_calculate !> Copies KPP surface boundary layer depth into BLD @@ -1231,7 +1414,7 @@ subroutine KPP_get_BLD(CS, BLD, G) type(KPP_CS), pointer :: CS !< Control structure for !! this module type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BLD!< bnd. layer depth (m) + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD!< bnd. layer depth (m) ! Local variables integer :: i,j do j = G%jsc, G%jec ; do i = G%isc, G%iec @@ -1243,22 +1426,22 @@ end subroutine KPP_get_BLD subroutine KPP_NonLocalTransport_temp(CS, G, GV, h, nonLocalTrans, surfFlux, & dt, scalar, C_p) - type(KPP_CS), intent(in) :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thickness (units of H) + type(KPP_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer/level thickness (units of H) real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: nonLocalTrans !< Non-local transport (non-dimensional) - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar (H/s * scalar) - real, intent(in) :: dt !< Time-step (s) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: scalar !< temperature - real, intent(in) :: C_p !< Seawater specific heat capacity (J/(kg*K)) + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: surfFlux !< Surface flux of scalar (H/s * scalar) + real, intent(in) :: dt !< Time-step (s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: scalar !< temperature + real, intent(in) :: C_p !< Seawater specific heat capacity (J/(kg*K)) integer :: i, j, k real, dimension( SZI_(G), SZJ_(G), SZK_(G) ) :: dtracer dtracer(:,:,:) = 0.0 -!$OMP parallel do default(none) shared(G,GV,dtracer,nonLocalTrans,h,surfFlux,CS,scalar,dt) + !$OMP parallel do default(shared) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1316,7 +1499,7 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, dtracer(:,:,:) = 0.0 -!$OMP parallel do default(none) shared(G,GV,dtracer,nonLocalTrans,h,surfFlux,CS,scalar,dt) + !$OMP parallel do default(shared) do k = 1, G%ke do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1377,7 +1560,7 @@ end subroutine KPP_end !! which is called directly by this module. !! !! The formulation and implementation of KPP is described in great detail in the -!! [CVMix manual](https://github.com/CVMix/CVMix-description/raw/master/cvmix.pdf) (written by our own Stephen Griffies). +!! [CVMix manual](https://github.com/CVMix/CVMix-description/raw/master/cvmix.pdf) (written by our own Steve Griffies). !! !! \subsection section_KPP_nutshell KPP in a nutshell !! @@ -1394,11 +1577,13 @@ end subroutine KPP_end !! Instead, the entire non-local transport term can be equivalently written !! \f[ K \gamma_s(\sigma) = C_s G(\sigma) Q_s \f] !! where \f$ Q_s \f$ is the surface flux of \f$ s \f$ and \f$ C_s \f$ is a constant. -!! The vertical structure of the redistribution (non-local) term is solely due to the shape function, \f$ G(\sigma) \f$. +!! The vertical structure of the redistribution (non-local) term is solely due to the shape function, +!! \f$ G(\sigma) \f$. !! In our implementation of KPP, we allow the shape functions used for \f$ K \f$ and for the non-local transport !! to be chosen independently. !! -!! [google_thread_NLT]: https://groups.google.com/forum/#!msg/CVMix-dev/i6rF-eHOtKI/Ti8BeyksrhAJ "Extreme values of non-local transport" +!! [google_thread_NLT]: https://groups.google.com/forum/#!msg/CVMix-dev/i6rF-eHOtKI/Ti8BeyksrhAJ +!! "Extreme values of non-local transport" !! !! The particular shape function most widely used in the atmospheric community is !! \f[ G(\sigma) = \sigma (1-\sigma)^2 \f] @@ -1408,7 +1593,8 @@ end subroutine KPP_end !! \f$ G^\prime(0) = 1 \f$, and !! \f$ G^\prime(1) = 0 \f$. !! Large et al, 1994, alter the function so as to match interior diffusivities but we have found that this leads -!! to inconsistencies within the formulation (see google groups thread [Extreme values of non-local transport][google_thread_NLT]). +!! to inconsistencies within the formulation (see google groups thread +!! [Extreme values of non-local transport][google_thread_NLT]). !! Instead, we use either the above form, or even simpler forms that use alternative upper boundary conditions. !! !! The KPP boundary layer depth is a function of the bulk Richardson number, Rib. @@ -1422,4 +1608,4 @@ end subroutine KPP_end !! !! \sa !! kpp_calculate(), kpp_applynonlocaltransport() -end module MOM_KPP +end module MOM_CVMix_KPP diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 4b422ccf9a..638c3f0a2d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -172,7 +172,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, CS, hbl) rho_lwr(:) = 0.0; rho_1d(:) = 0.0 if (.not. associated(hbl)) then - allocate(hbl(SZI_(G), SZJ_(G))); + allocate(hbl(SZI_(G), SZJ_(G))) hbl(:,:) = 0.0 endif @@ -212,6 +212,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, CS, hbl) iFaceHeight(k+1) = iFaceHeight(k) - dh enddo + ! gets index of the level and interface above hbl kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) call CVMix_coeffs_conv(Mdiff_out=CS%kv_conv(i,j,:), & @@ -259,6 +260,8 @@ end function CVMix_conv_is_used subroutine CVMix_conv_end(CS) type(CVMix_conv_cs), pointer :: CS ! Control structure + if (.not. associated(CS)) return + deallocate(CS%N2) deallocate(CS%kd_conv) deallocate(CS%kv_conv) diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 new file mode 100644 index 0000000000..7137aabfa6 --- /dev/null +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -0,0 +1,301 @@ +!> Interface to CVMix double diffusion scheme. +module MOM_CVMix_ddiff + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_diag_mediator, only : diag_ctrl, time_type, register_diag_field +use MOM_diag_mediator, only : post_data +use MOM_EOS, only : calculate_density_derivs +use MOM_variables, only : thermo_var_ptrs +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : openParameterBlock, closeParameterBlock +use MOM_debugging, only : hchksum +use MOM_grid, only : ocean_grid_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_file_parser, only : get_param, log_version, param_file_type +use cvmix_ddiff, only : cvmix_init_ddiff, CVMix_coeffs_ddiff +use cvmix_kpp, only : CVmix_kpp_compute_kOBL_depth +implicit none ; private + +#include + +public CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_is_used, compute_ddiff_coeffs + +!> Control structure including parameters for CVMix double diffusion. +type, public :: CVMix_ddiff_cs + + ! Parameters + real :: strat_param_max !< maximum value for the stratification parameter (nondim) + real :: kappa_ddiff_s !< leading coefficient in formula for salt-fingering regime + !! for salinity diffusion (m^2/s) + real :: ddiff_exp1 !< interior exponent in salt-fingering regime formula (nondim) + real :: ddiff_exp2 !< exterior exponent in salt-fingering regime formula (nondim) + real :: mol_diff !< molecular diffusivity (m^2/s) + real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime (nondim) + real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime (nondim) + real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime (nondim) + real :: min_thickness !< Minimum thickness allowed (m) + character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & + !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") + logical :: debug !< If true, turn on debugging + + ! Daignostic handles and pointers + type(diag_ctrl), pointer :: diag => NULL() + integer :: id_KT_extra = -1, id_KS_extra = -1, id_R_rho = -1 + + ! Diagnostics arrays + real, allocatable, dimension(:,:,:) :: KT_extra !< double diffusion diffusivity for temp (m2/s) + real, allocatable, dimension(:,:,:) :: KS_extra !< double diffusion diffusivity for salt (m2/s) + real, allocatable, dimension(:,:,:) :: R_rho !< double-diffusion density ratio (nondim) + +end type CVMix_ddiff_cs + +character(len=40) :: mdl = "MOM_CVMix_ddiff" !< This module's name. + +contains + +!> Initialized the CVMix double diffusion module. +logical function CVMix_ddiff_init(Time, G, GV, param_file, diag, CS) + + type(time_type), intent(in) :: Time !< The current time. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. + type(CVMix_ddiff_cs), pointer :: CS !< This module's control structure. + +! This include declares and sets the variable "version". +#include "version_variable.h" + + if (associated(CS)) then + call MOM_error(WARNING, "CVMix_ddiff_init called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ! Read parameters + call log_version(param_file, mdl, version, & + "Parameterization of mixing due to double diffusion processes via CVMix") + call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_init, & + "If true, turns on double diffusive processes via CVMix. \n"// & + "Note that double diffusive processes on viscosity are ignored \n"// & + "in CVMix, see http://cvmix.github.io/ for justification.",& + default=.false.) + + if (.not. CVMix_ddiff_init) return + + call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) + + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, do_not_log=.True.) + + call openParameterBlock(param_file,'CVMIX_DDIFF') + + call get_param(param_file, mdl, "STRAT_PARAM_MAX", CS%strat_param_max, & + "The maximum value for the double dissusion stratification parameter", & + units="nondim", default=2.55) + + call get_param(param_file, mdl, "KAPPA_DDIFF_S", CS%kappa_ddiff_s, & + "Leading coefficient in formula for salt-fingering regime \n"// & + "for salinity diffusion.", units="m2 s-1", default=1.0e-4) + + call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & + "Interior exponent in salt-fingering regime formula.", & + units="nondim", default=1.0) + + call get_param(param_file, mdl, "DDIFF_EXP2", CS%ddiff_exp2, & + "Exterior exponent in salt-fingering regime formula.", & + units="nondim", default=3.0) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM1", CS%kappa_ddiff_param1, & + "Exterior coefficient in diffusive convection regime.", & + units="nondim", default=0.909) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM2", CS%kappa_ddiff_param2, & + "Middle coefficient in diffusive convection regime.", & + units="nondim", default=4.6) + + call get_param(param_file, mdl, "KAPPA_DDIFF_PARAM3", CS%kappa_ddiff_param3, & + "Interior coefficient in diffusive convection regime.", & + units="nondim", default=-0.54) + + call get_param(param_file, mdl, "MOL_DIFF", CS%mol_diff, & + "Molecular diffusivity used in CVMix double diffusion.", & + units="m2 s-1", default=1.5e-6) + + call get_param(param_file, mdl, "DIFF_CONV_TYPE", CS%diff_conv_type, & + "type of diffusive convection to use. Options are Marmorino \n" //& + "and Caldwell 1976 (MC76) and Kelley 1988, 1990 (K90).", & + default="MC76") + + call closeParameterBlock(param_file) + + ! Register diagnostics + CS%diag => diag + + CS%id_KT_extra = register_diag_field('ocean_model','KT_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for temperature', 'm2 s-1') + + CS%id_KS_extra = register_diag_field('ocean_model','KS_extra',diag%axesTi,Time, & + 'Double-diffusive diffusivity for salinity', 'm2 s-1') + + CS%id_R_rho = register_diag_field('ocean_model','R_rho',diag%axesTi,Time, & + 'Double-diffusion density ratio', 'nondim') + if (CS%id_R_rho > 0) & + allocate(CS%R_rho( SZI_(G), SZJ_(G), SZK_(G)+1)); CS%R_rho(:,:,:) = 0.0 + + call cvmix_init_ddiff(strat_param_max=CS%strat_param_max, & + kappa_ddiff_s=CS%kappa_ddiff_s, & + ddiff_exp1=CS%ddiff_exp1, & + ddiff_exp2=CS%ddiff_exp2, & + mol_diff=CS%mol_diff, & + kappa_ddiff_param1=CS%kappa_ddiff_param1, & + kappa_ddiff_param2=CS%kappa_ddiff_param2, & + kappa_ddiff_param3=CS%kappa_ddiff_param3, & + diff_conv_type=CS%diff_conv_type) + +end function CVMix_ddiff_init + +!> Subroutine for computing vertical diffusion coefficients for the +!! double diffusion mixing parameterization. +subroutine compute_ddiff_coeffs(h, tv, G, GV, j, Kd_T, Kd_S, CS) + + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: Kd_T !< Interface double diffusion diapycnal + !! diffusivity for temp (m2/sec). + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: Kd_S !< Interface double diffusion diapycnal + !! diffusivity for salt (m2/sec). + type(CVMix_ddiff_cs), pointer :: CS !< The control structure returned + !! by a previous call to CVMix_ddiff_init. + integer, intent(in) :: j !< Meridional grid indice. +! real, dimension(:,:), optional, pointer :: hbl !< Depth of ocean boundary layer (m) + + ! local variables + real, dimension(SZK_(G)) :: & + cellHeight, & !< Height of cell centers (m) + dRho_dT, & !< partial derivatives of density wrt temp (kg m-3 degC-1) + dRho_dS, & !< partial derivatives of density wrt saln (kg m-3 PPT-1) + pres_int, & !< pressure at each interface (Pa) + temp_int, & !< temp and at interfaces (degC) + salt_int, & !< salt at at interfaces + alpha_dT, & !< alpha*dT across interfaces + beta_dS, & !< beta*dS across interfaces + dT, & !< temp. difference between adjacent layers (degC) + dS !< salt difference between adjacent layers + + real, dimension(SZK_(G)+1) :: iFaceHeight !< Height of interfaces (m) + integer :: kOBL !< level of OBL extent + real :: pref, g_o_rho0, rhok, rhokm1, dz, dh, hcorr + integer :: i, k + + ! initialize dummy variables + pres_int(:) = 0.0; temp_int(:) = 0.0; salt_int(:) = 0.0 + alpha_dT(:) = 0.0; beta_dS(:) = 0.0; dRho_dT(:) = 0.0 + dRho_dS(:) = 0.0; dT(:) = 0.0; dS(:) = 0.0 + + ! set Kd_T and Kd_S to zero to avoid passing values from previous call + Kd_T(:,j,:) = 0.0; Kd_S(:,j,:) = 0.0 + + ! GMM, I am leaving some code commented below. We need to pass BLD to + ! this soubroutine to avoid adding diffusivity above that. This needs + ! to be done once we re-structure the order of the calls. + !if (.not. associated(hbl)) then + ! allocate(hbl(SZI_(G), SZJ_(G))); + ! hbl(:,:) = 0.0 + !endif + + do i = G%isc, G%iec + + ! skip calling at land points + if (G%mask2dT(i,j) == 0.) cycle + + pRef = 0. + pres_int(1) = pRef + ! we don't have SST and SSS, so let's use values at top-most layer + temp_int(1) = TV%T(i,j,1); salt_int(1) = TV%S(i,j,1) + do k=2,G%ke + ! pressure at interface + pres_int(k) = pRef + GV%H_to_Pa * h(i,j,k-1) + ! temp and salt at interface + ! for temp: (t1*h1 + t2*h2)/(h1+h2) + temp_int(k) = (TV%T(i,j,k-1)*h(i,j,k-1) + TV%T(i,j,k)*h(i,j,k))/(h(i,j,k-1)+h(i,j,k)) + salt_int(k) = (TV%S(i,j,k-1)*h(i,j,k-1) + TV%S(i,j,k)*h(i,j,k))/(h(i,j,k-1)+h(i,j,k)) + ! dT and dS + dT(k) = (TV%T(i,j,k-1)-TV%T(i,j,k)) + dS(k) = (TV%S(i,j,k-1)-TV%S(i,j,k)) + pRef = pRef + GV%H_to_Pa * h(i,j,k-1) + enddo ! k-loop finishes + + call calculate_density_derivs(temp_int(:), salt_int(:), pres_int(:), drho_dT(:), drho_dS(:), 1, G%ke, TV%EQN_OF_STATE) + + ! The "-1.0" below is needed so that the following criteria is satisfied: + ! if ((alpha_dT > beta_dS) .and. (beta_dS > 0.0)) then "salt finger" + ! if ((alpha_dT < 0.) .and. (beta_dS < 0.) .and. (alpha_dT > beta_dS)) then "diffusive convection" + do k=1,G%ke + alpha_dT(k) = -1.0*drho_dT(k) * dT(k) + beta_dS(k) = drho_dS(k) * dS(k) + enddo + + if (CS%id_R_rho > 0.0) then + do k=1,G%ke + CS%R_rho(i,j,k) = alpha_dT(k)/beta_dS(k) + ! avoid NaN's + if(CS%R_rho(i,j,k) /= CS%R_rho(i,j,k)) CS%R_rho(i,j,k) = 0.0 + enddo + endif + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0.0 + ! compute heights at cell center and interfaces + do k=1,G%ke + dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + ! gets index of the level and interface above hbl + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) + + call CVMix_coeffs_ddiff(Tdiff_out=Kd_T(i,j,:), & + Sdiff_out=Kd_S(i,j,:), & + strat_param_num=alpha_dT(:), & + strat_param_denom=beta_dS(:), & + nlev=G%ke, & + max_nlev=G%ke) + + ! Do not apply mixing due to convection within the boundary layer + !do k=1,kOBL + ! Kd_T(i,j,k) = 0.0 + ! Kd_S(i,j,k) = 0.0 + !enddo + + enddo ! i-loop + +end subroutine compute_ddiff_coeffs + +!> Reads the parameter "USE_CVMIX_DDIFF" and returns state. +!! This function allows other modules to know whether this parameterization will +!! be used without needing to duplicate the log entry. +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.) + +end function CVMix_ddiff_is_used + +!> Clear pointers and dealocate memory +subroutine CVMix_ddiff_end(CS) + type(CVMix_ddiff_cs), pointer :: CS ! Control structure + + deallocate(CS) + +end subroutine CVMix_ddiff_end + + +end module MOM_CVMix_ddiff diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index f99a0d4dcb..49b1e5c326 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -30,18 +30,21 @@ module MOM_CVMix_shear !> Control structure including parameters for CVMix interior shear schemes. type, public :: CVMix_shear_cs logical :: use_LMD94, use_PP81 !< Flags for various schemes + logical :: smooth_ri !< If true, smooth Ri using a 1-2-1 filter real :: Ri_zero !< LMD94 critical Richardson number real :: Nu_zero !< LMD94 maximum interior diffusivity - real :: KPP_exp !< + real :: KPP_exp !< Exponent of unitless factor of diff. + !! for KPP internal shear mixing scheme. real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency (1/s2) real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency (1/s2) real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number -! real, allocatable, dimension(:,:,:) :: kv !< vertical viscosity at interface (m2/s) -! real, allocatable, dimension(:,:,:) :: kd !< vertical diffusivity at interface (m2/s) + real, allocatable, dimension(:,:,:) :: ri_grad_smooth !< Gradient Richardson number + !! after smoothing character(10) :: Mix_Scheme !< Mixing scheme name (string) ! Daignostic handles and pointers type(diag_ctrl), pointer :: diag => NULL() integer :: id_N2 = -1, id_S2 = -1, id_ri_grad = -1, id_kv = -1, id_kd = -1 + integer :: id_ri_grad_smooth = -1 end type CVMix_shear_cs @@ -52,24 +55,25 @@ module MOM_CVMix_shear !> Subroutine for calculating (internal) vertical diffusivities/viscosities subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & kv, G, GV, CS ) - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: u_H !< Initial zonal velocity on T points, in m s-1. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: v_H !< Initial meridional velocity on T points, in m s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface - !! (not layer!) in m2 s-1. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface - !! (not layer!) in m2 s-1. - type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous call to - !! CVMix_shear_init. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness, in m or kg m-2. + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kd !< The vertical diffusivity at each interface + !! (not layer!) in m2 s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(out) :: kv !< The vertical viscosity at each interface + !! (not layer!) in m2 s-1. + type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous call to + !! CVMix_shear_init. ! Local variables integer :: i, j, k, kk, km1 - real :: gorho - real :: pref, DU, DV, DRHO, DZ, N2, S2 + real :: GoRho + real :: pref, DU, DV, DRHO, DZ, N2, S2, dummy real, dimension(2*(G%ke)) :: pres_1d, temp_1d, salt_1d, rho_1d real, dimension(G%ke+1) :: Ri_Grad !< Gradient Richardson number + real, parameter :: epsln = 1.e-10 !< Threshold to identify vanished layers ! some constants GoRho = GV%g_Earth / GV%Rho0 @@ -115,19 +119,42 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & DZ = ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) N2 = DRHO/DZ S2 = (DU*DU+DV*DV)/(DZ*DZ) - Ri_Grad(k) = max(0.,N2)/max(S2,1.e-16) + Ri_Grad(k) = max(0.,N2)/max(S2,1.e-10) ! fill 3d arrays, if user asks for diagsnostics if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 if (CS%id_S2 > 0) CS%S2(i,j,k) = S2 - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,k) = Ri_Grad(k) enddo + Ri_grad(G%ke+1) = Ri_grad(G%ke) + + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + + if (CS%smooth_ri) then + ! 1) fill Ri_grad in vanished layers with adjacent value + do k = 2, G%ke + if (h(i,j,k) .le. epsln) Ri_grad(k) = Ri_grad(k-1) + enddo + + Ri_grad(G%ke+1) = Ri_grad(G%ke) + + ! 2) vertically smooth Ri with 1-2-1 filter + dummy = 0.25 * Ri_grad(2) + Ri_grad(G%ke+1) = Ri_grad(G%ke) + do k = 3, G%ke + Ri_Grad(k) = dummy + 0.5 * Ri_Grad(k) + 0.25 * Ri_grad(k+1) + dummy = 0.25 * Ri_grad(k) + enddo + + if (CS%id_ri_grad_smooth > 0) CS%ri_grad_smooth(i,j,:) = Ri_Grad(:) + endif + + ! Call to CVMix wrapper for computing interior mixing coefficients. call CVMix_coeffs_shear(Mdiff_out=kv(i,j,:), & Tdiff_out=kd(i,j,:), & - RICH=Ri_Grad, & + RICH=Ri_Grad(:), & nlev=G%ke, & max_nlev=G%ke) enddo @@ -139,6 +166,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, & if (CS%id_N2 > 0) call post_data(CS%id_N2,CS%N2, CS%diag) if (CS%id_S2 > 0) call post_data(CS%id_S2,CS%S2, CS%diag) if (CS%id_ri_grad > 0) call post_data(CS%id_ri_grad,CS%ri_grad, CS%diag) + if (CS%id_ri_grad_smooth > 0) call post_data(CS%id_ri_grad_smooth,CS%ri_grad_smooth, CS%diag) end subroutine calculate_CVMix_shear @@ -188,7 +216,7 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) if (use_JHL) NumberTrue = NumberTrue + 1 ! After testing for interior schemes, make sure only 0 or 1 are enabled. ! Otherwise, warn user and kill job. - if ((NumberTrue).gt.1) then + if ((NumberTrue) > 1) then call MOM_error(FATAL, 'MOM_CVMix_shear_init: '// & 'Multiple shear driven internal mixing schemes selected,'//& ' please disable all but one scheme to proceed.') @@ -204,12 +232,16 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) "Critical Richardson for KPP shear mixing,"// & " NOTE this the internal mixing and this is"// & " not for setting the boundary layer depth." & - ,units="nondim", default=0.7) + ,units="nondim", default=0.8) call get_param(param_file, mdl, "KPP_EXP", CS%KPP_exp, & "Exponent of unitless factor of diffusivities,"// & " for KPP internal shear mixing scheme." & ,units="nondim", default=3.0) - call CVMix_init_shear(mix_scheme=CS%mix_scheme, & + call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & + "If true, vertically smooth the Richardson"// & + "number by applying a 1-2-1 filter once.", & + default = .false.) + call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & KPP_nu_zero=CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & KPP_exp=CS%KPP_exp) @@ -232,6 +264,12 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) if (CS%id_ri_grad > 0) & !Initialize w/ large Richardson value allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(G)+1 ));CS%ri_grad(:,:,:) = 1.e8 + CS%id_ri_grad_smooth = register_diag_field('ocean_model', 'ri_grad_shear_smooth', & + diag%axesTi, Time, & + 'Smoothed gradient Richarson number used by MOM_CVMix_shear module','nondim') + if (CS%id_ri_grad_smooth > 0) & !Initialize w/ large Richardson value + allocate( CS%ri_grad_smooth( SZI_(G), SZJ_(G), SZK_(G)+1 ));CS%ri_grad_smooth(:,:,:) = 1.e8 + CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s') CS%id_kv = register_diag_field('ocean_model', 'kv_shear_CVMix', diag%axesTi, Time, & @@ -257,6 +295,8 @@ end function CVMix_shear_is_used subroutine CVMix_shear_end(CS) type(CVMix_shear_cs), pointer :: CS ! Control structure + if (.not. associated(CS)) return + if (CS%id_N2 > 0) deallocate(CS%N2) if (CS%id_S2 > 0) deallocate(CS%S2) if (CS%id_ri_grad > 0) deallocate(CS%ri_grad) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index e9441d36e5..bb1e0b11c1 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -272,7 +272,7 @@ subroutine sfc_bkgnd_mixing(G, CS) if (.not. CS%Bryan_Lewis_diffusivity) then -!$OMP parallel do default(none) shared(is,ie,js,je,CS,Kd_sfc) +!$OMP parallel do default(none) shared(is,ie,js,je,CS) do j=js,je ; do i=is,ie CS%Kd_sfc(i,j) = CS%Kd enddo ; enddo @@ -280,16 +280,16 @@ subroutine sfc_bkgnd_mixing(G, CS) if (CS%Henyey_IGW_background) then I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. -!$OMP parallel do default(none) -!shared(is,ie,js,je,Kd_sfc,CS,G,deg_to_rad,epsilon,I_x30) & -!$OMP private(abs_sin) +!$OMP parallel do default(none) & +!$OMP shared(is,ie,js,je,CS,G,deg_to_rad,epsilon,I_x30) & +!$OMP private(abs_sin) do j=js,je ; do i=is,ie abs_sin = abs(sin(G%geoLatT(i,j)*deg_to_rad)) CS%Kd_sfc(i,j) = max(CS%Kd_min, CS%Kd_sfc(i,j) * & ((abs_sin * invcosh(CS%N0_2Omega/max(epsilon,abs_sin))) * I_x30) ) enddo ; enddo elseif (CS%Kd_tanh_lat_fn) then -!$OMP parallel do default(none) shared(is,ie,js,je,Kd_sfc,CS,G) +!$OMP parallel do default(none) shared(is,ie,js,je,CS,G) do j=js,je ; do i=is,ie ! The transition latitude and latitude range are hard-scaled here, since ! this is not really intended for wide-spread use, but rather for @@ -408,7 +408,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, kd_lay, kv, j, G, GV, CS) CS%kd_bkgnd(i,j,1) = 0.0; CS%kv_bkgnd(i,j,1) = 0.0 CS%kd_bkgnd(i,j,nz+1) = 0.0; CS%kv_bkgnd(i,j,nz+1) = 0.0 do k=2,nz - CS%kd_bkgnd(i,j,k) = CS%kd_bkgnd(i,j,k) + 0.5*(kd_lay(i,j,K-1) + kd_lay(i,j,K)) + CS%kd_bkgnd(i,j,k) = 0.5*(kd_lay(i,j,K-1) + kd_lay(i,j,K)) CS%kv_bkgnd(i,j,k) = CS%kd_bkgnd(i,j,k) * CS%prandtl_bkgnd enddo enddo diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 7b2b39f242..7eafb011bd 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -441,10 +441,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & "Module must be initialized before it is used.") if (GV%nkml < 1) return - if (.not. ASSOCIATED(tv%eqn_of_state)) call MOM_error(FATAL, & + if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & "MOM_mixed_layer: Temperature, salinity and an equation of state "//& "must now be used.") - if (.NOT. ASSOCIATED(fluxes%ustar)) call MOM_error(FATAL, & + if (.NOT. associated(fluxes%ustar)) call MOM_error(FATAL, & "MOM_mixed_layer: No surface TKE fluxes (ustar) defined in mixedlayer!") nkmb = CS%nkml+CS%nkbl @@ -503,13 +503,13 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & CS%diag_TKE_conv_decay(i,j) = 0.0 ; CS%diag_TKE_conv_s2(i,j) = 0.0 enddo ; enddo endif - if (ALLOCATED(CS%diag_PE_detrain)) then + if (allocated(CS%diag_PE_detrain)) then !$OMP do do j=js,je ; do i=is,ie CS%diag_PE_detrain(i,j) = 0.0 enddo ; enddo endif - if (ALLOCATED(CS%diag_PE_detrain2)) then + if (allocated(CS%diag_PE_detrain2)) then !$OMP do do j=js,je ; do i=is,ie CS%diag_PE_detrain2(i,j) = 0.0 @@ -548,7 +548,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 enddo ; enddo - if(id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) + if (id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) ! Calculate an estimate of the mid-mixed layer pressure (in Pa) do i=is,ie ; p_ref(i) = 0.0 ; enddo do k=1,CS%nkml ; do i=is,ie @@ -564,21 +564,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & ie-is+1, tv%eqn_of_state) enddo - if(id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) + if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) if (CS%ML_resort) then - if(id_clock_resort>0) call cpu_clock_begin(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_begin(id_clock_resort) if (CS%ML_presort_nz_conv_adj > 0) & call convective_adjustment(h(:,1:), u, v, R0(:,1:), Rcv(:,1:), T(:,1:), & S(:,1:), eps, d_eb, dKE_CA, cTKE, j, G, GV, CS, & CS%ML_presort_nz_conv_adj) call sort_ML(h(:,1:), R0(:,1:), eps, G, GV, CS, ksort) - if(id_clock_resort>0) call cpu_clock_end(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_end(id_clock_resort) else do k=1,nz ; do i=is,ie ; ksort(i,k) = k ; enddo ; enddo - if(id_clock_adjustment>0) call cpu_clock_begin(id_clock_adjustment) + if (id_clock_adjustment>0) call cpu_clock_begin(id_clock_adjustment) ! Undergo instantaneous entrainment into the buffer layers and mixed layers ! to remove hydrostatic instabilities. Any water that is lighter than ! currently in the mixed or buffer layer is entrained. @@ -586,7 +586,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & S(:,1:), eps, d_eb, dKE_CA, cTKE, j, G, GV, CS) do i=is,ie ; h_CA(i) = h(i,1) ; enddo - if(id_clock_adjustment>0) call cpu_clock_end(id_clock_adjustment) + if (id_clock_adjustment>0) call cpu_clock_end(id_clock_adjustment) endif if (associated(fluxes%lrunoff) .and. CS%do_rivermix) then @@ -611,7 +611,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & endif - if(id_clock_conv>0) call cpu_clock_begin(id_clock_conv) + if (id_clock_conv>0) call cpu_clock_begin(id_clock_conv) ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: @@ -635,7 +635,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & dKE_FC, j, ksort, G, GV, CS, tv, fluxes, dt, & aggregate_FW_forcing) - if(id_clock_conv>0) call cpu_clock_end(id_clock_conv) + if (id_clock_conv>0) call cpu_clock_end(id_clock_conv) ! Now the mixed layer undergoes mechanically forced entrainment. ! The mixed layer may entrain down to the Monin-Obukhov depth if the @@ -643,7 +643,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! First the TKE at the depth of free convection that is available ! to drive mixing is calculated. - if(id_clock_mech>0) call cpu_clock_begin(id_clock_mech) + if (id_clock_mech>0) call cpu_clock_begin(id_clock_mech) call find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & @@ -662,7 +662,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & if (CS%TKE_diagnostics) then ; do i=is,ie CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) - Idt_diag*TKE(i) enddo ; endif - if(id_clock_mech>0) call cpu_clock_end(id_clock_mech) + if (id_clock_mech>0) call cpu_clock_end(id_clock_mech) ! Calculate the homogeneous mixed layer properties and store them in layer 0. do i=is,ie ; if (htot(i) > 0.0) then @@ -674,10 +674,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & T(i,0) = T(i,1) ; S(i,0) = S(i,1) ; R0(i,0) = R0(i,1) ; Rcv(i,0) = Rcv(i,1) h(i,0) = htot(i) endif ; enddo - if (write_diags .and. ALLOCATED(CS%ML_depth)) then ; do i=is,ie + if (write_diags .and. allocated(CS%ML_depth)) then ; do i=is,ie CS%ML_depth(i,j) = h(i,0) * GV%H_to_m enddo ; endif - if (ASSOCIATED(Hml)) then ; do i=is,ie + if (associated(Hml)) then ; do i=is,ie Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_m) enddo ; endif @@ -692,10 +692,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! these unused layers (but not currently in the code). if (CS%ML_resort) then - if(id_clock_resort>0) call cpu_clock_begin(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_begin(id_clock_resort) call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), GV%Rlay, eps, & d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) - if(id_clock_resort>0) call cpu_clock_end(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_end(id_clock_resort) endif if (CS%limit_det .or. (CS%id_Hsfc_max > 0) .or. (CS%id_Hsfc_min > 0)) then @@ -726,7 +726,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! Move water left in the former mixed layer into the buffer layer and ! from the buffer layer into the interior. These steps might best be ! treated in conjuction. - if(id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) + if (id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) if (CS%nkbl == 1) then call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & GV%Rlay, dt, dt__diag, d_ea, d_eb, j, G, GV, CS, & @@ -739,7 +739,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! This code only works with 1 or 2 buffer layers. call MOM_error(FATAL, "MOM_mixed_layer: CS%nkbl must be 1 or 2 for now.") endif - if(id_clock_detrain>0) call cpu_clock_end(id_clock_detrain) + if (id_clock_detrain>0) call cpu_clock_end(id_clock_detrain) if (CS%id_Hsfc_used > 0) then @@ -1221,10 +1221,10 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & (dRcv_dT(i)*(Net_heat(i) + Pen_absorbed) - & dRcv_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 - if(ASSOCIATED(fluxes%heat_content_massin)) & + if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) & + T_precip * netMassIn(i) * GV%H_to_kg_m2 * fluxes%C_p * Idt - if (ASSOCIATED(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T_precip * netMassIn(i) * GV%H_to_kg_m2 endif ; enddo @@ -1274,10 +1274,10 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_kg_m2*fluxes%C_p*Idt ! by uncommenting the lines here. ! we will also then completely remove TempXpme from the model. - if(ASSOCIATED(fluxes%heat_content_massout)) & + if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) & - T(i,k)*h_evap*GV%H_to_kg_m2 * fluxes%C_p * Idt - if (ASSOCIATED(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & T(i,k)*h_evap*GV%H_to_kg_m2 endif @@ -1343,7 +1343,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_prev = h_ent ; h_ent = h_prev+dh_Newt if (h_ent > h_max) then h_ent = 0.5*(h_prev+h_max) - else if (h_ent < h_min) then + elseif (h_ent < h_min) then h_ent = 0.5*(h_prev+h_min) endif @@ -2977,7 +2977,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h_det_to_h1 = h_to_bl - h_det_to_h2 h_ml_to_h1 = MAX(h_min_bl-h_det_to_h1,0.0) - Ih = 1.0/h_min_bl; + Ih = 1.0/h_min_bl Ihdet = 0.0 ; if (h_to_bl > 0.0) Ihdet = 1.0 / h_to_bl Ih1f = 1.0 / (h_det_to_h1 + h_ml_to_h1) @@ -3006,7 +3006,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,0) = h(i,0) - (h_ml_to_h1 + h_ml_to_h2) - if (ALLOCATED(CS%diag_PE_detrain) .or. ALLOCATED(CS%diag_PE_detrain2)) then + if (allocated(CS%diag_PE_detrain) .or. allocated(CS%diag_PE_detrain2)) then R0_det = R0_to_bl*Ihdet s1en = G_2 * Idt_H2 * ( ((R0(i,kb2)-R0(i,kb1))*h1*h2 + & h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & @@ -3014,10 +3014,10 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (R0_det-R0(i,0))*h_det_to_h2 ) + & h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap ) - if (ALLOCATED(CS%diag_PE_detrain)) & + if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + s1en - if (ALLOCATED(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & CS%diag_PE_detrain2(i,j) + s1en + Idt_H2*Rho0xG*dPE_extrap endif @@ -3215,9 +3215,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,kb1) = stays + h_to_bl h(i,kb2) = h1_to_h2 h(i,k0) = h(i,k0) + (h1_to_k0 + h2) - if (ALLOCATED(CS%diag_PE_detrain)) & + if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge - if (ALLOCATED(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det+Rho0xG*dPE_extrap) else ! Not mergeable_bl. ! There is no further detrainment from the buffer layers, and the @@ -3291,9 +3291,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,kb1) = stays + h_to_bl h(i,kb2) = h(i,kb2) + h1_to_h2 - if (ALLOCATED(CS%diag_PE_detrain)) & + if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det - if (ALLOCATED(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det+Rho0xG*dPE_extrap) endif endif ! End of detrainment... @@ -3412,10 +3412,10 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & g_H2_2Rho0dt * h(i,k) * h(i,nkmb) * & (R0(i,nkmb) - R0(i,k)) - if (ALLOCATED(CS%diag_PE_detrain)) & + if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - if (ALLOCATED(CS%diag_PE_detrain2)) & + if (allocated(CS%diag_PE_detrain2)) & CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + & g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) @@ -3462,7 +3462,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e d_eb(i,nkmb) = d_eb(i,nkmb) - detrain(i) d_ea(i,nkmb) = d_ea(i,nkmb) + detrain(i) - if (ALLOCATED(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & CS%diag_PE_detrain(i,j) + g_H2_2dt * detrain(i)* & (h(i,0) + h(i,nkmb)) * (R0(i,nkmb) - R0(i,0)) x1 = R0(i,0) @@ -3542,7 +3542,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e detrain(i) = h(i,nkmb)*(Rcv(i,nkmb) - RcvTgt(k)) / & (RcvTgt(k+1) - RcvTgt(k)) - if (ALLOCATED(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * & (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dR0_dRcv @@ -3591,7 +3591,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e h(i,k+1) = h(i,k+1) + detrain(i) h(i,nkmb) = h(i,nkmb) - detrain(i) - if (ALLOCATED(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) endif @@ -3868,7 +3868,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) if (CS%id_PE_detrain2 > 0) call safe_alloc_alloc(CS%diag_PE_detrain2, isd, ied, jsd, jed) if (CS%id_ML_depth > 0) call safe_alloc_alloc(CS%ML_depth, isd, ied, jsd, jed) - if(CS%allow_clocks_in_omp_loops) then + if (CS%allow_clocks_in_omp_loops) then id_clock_detrain = cpu_clock_id('(Ocean mixed layer detrain)', grain=CLOCK_ROUTINE) id_clock_mech = cpu_clock_id('(Ocean mixed layer mechanical entrainment)', grain=CLOCK_ROUTINE) id_clock_conv = cpu_clock_id('(Ocean mixed layer convection)', grain=CLOCK_ROUTINE) @@ -3895,12 +3895,12 @@ end subroutine bulkmixedlayer_init !! and +25% at x~3.5, but the exponential deemphasizes the importance of !! large x. When L=0, EF4 returns E/((H+E)*H). function EF4(H, E, L, dR_de) -real, intent(in) :: H !< Total thickness, in m or kg m-2. (Intent in) The units of h - !! are referred to as H below. -real, intent(in) :: E !< Entrainment, in units of H. -real, intent(in) :: L !< The e-folding scale in H-1. -real, intent(inout), optional :: dR_de !< The partial derivative of the result R with E, in H-2. -real :: EF4 + real, intent(in) :: H !< Total thickness, in m or kg m-2. (Intent in) The units of h + !! are referred to as H below. + real, intent(in) :: E !< Entrainment, in units of H. + real, intent(in) :: L !< The e-folding scale in H-1. + real, optional, intent(inout) :: dR_de !< The partial derivative of the result R with E, in H-2. + real :: EF4 ! This subroutine returns an approximation to the integral ! R = exp(-L*(H+E)) integral(LH to L(H+E)) L/(1-(1+x)exp(-x)) dx. ! The approximation to the integrand is good to within -2% at x~.3 diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 9588ac3a5c..528dc33135 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -2,53 +2,6 @@ module MOM_diabatic_aux ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - July 2000 * -!* Alistair Adcroft, and Stephen Griffies * -!* * -!* This program contains the subroutine that, along with the * -!* subroutines that it calls, implements diapycnal mass and momentum * -!* fluxes and a bulk mixed layer. The diapycnal diffusion can be * -!* used without the bulk mixed layer. * -!* * -!* diabatic first determines the (diffusive) diapycnal mass fluxes * -!* based on the convergence of the buoyancy fluxes within each layer. * -!* The dual-stream entrainment scheme of MacDougall and Dewar (JPO, * -!* 1997) is used for combined diapycnal advection and diffusion, * -!* calculated implicitly and potentially with the Richardson number * -!* dependent mixing, as described by Hallberg (MWR, 2000). Diapycnal * -!* advection is fundamentally the residual of diapycnal diffusion, * -!* so the fully implicit upwind differencing scheme that is used is * -!* entirely appropriate. The downward buoyancy flux in each layer * -!* is determined from an implicit calculation based on the previously * -!* calculated flux of the layer above and an estimated flux in the * -!* layer below. This flux is subject to the following conditions: * -!* (1) the flux in the top and bottom layers are set by the boundary * -!* conditions, and (2) no layer may be driven below an Angstrom thick-* -!* ness. If there is a bulk mixed layer, the buffer layer is treat- * -!* ed as a fixed density layer with vanishingly small diffusivity. * -!* * -!* diabatic takes 5 arguments: the two velocities (u and v), the * -!* thicknesses (h), a structure containing the forcing fields, and * -!* the length of time over which to act (dt). The velocities and * -!* thickness are taken as inputs and modified within the subroutine. * -!* There is no limit on the time step. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v * -!* j x ^ x ^ x At >: u * -!* j > o > o > At o: h, T, S, buoy, ustar, ea, eb, etc. * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -123,7 +76,7 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) type(thermo_var_ptrs), intent(inout) :: tv type(diabatic_aux_CS), intent(in) :: CS - real, dimension(SZI_(G),SZJ_(G)), intent(in), optional :: p_surf + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: p_surf ! Frazil formation keeps the temperature above the freezing point. ! This subroutine warms any water that is colder than the (currently @@ -239,26 +192,19 @@ subroutine make_frazil(h, tv, G, GV, CS, p_surf) end subroutine make_frazil +!> Applies double diffusion to T & S, assuming no diapycal mass +!! fluxes, using a simple triadiagonal solver. subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(vertvisc_type), intent(in) :: visc - real, intent(in) :: dt - -! This subroutine applies double diffusion to T & S, assuming no diapycal mass -! fluxes, using a simple triadiagonal solver. - -! Arguments: h - Layer thickness, in m or kg m-2. -! (in) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) visc - A structure containing vertical viscosities, bottom boundary -! layer properies, and related fields. -! (in) dt - Time increment, in s. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. + type(thermo_var_ptrs), intent(inout) :: tv !< pointers to any available modynamic fields. + !! Absent fields have NULL ptrs. + type(vertvisc_type), intent(in) :: visc !< structure containing vertical viscosities, + !! layer properies, and related fields. + real, intent(in) :: dt !< Time increment, in s. + ! local variables real, dimension(SZI_(G)) :: & b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S, in H. d1_T, d1_S ! Variables used by the tridiagonal solvers, nondim. @@ -345,30 +291,25 @@ subroutine differential_diffuse_T_S(h, tv, visc, dt, G, GV) S(i,j,k) = S(i,j,k) + c1_S(i,k+1)*S(i,j,k+1) enddo ; enddo enddo - end subroutine differential_diffuse_T_S +!> Keep salinity from falling below a small but positive threshold +!! This occurs when the ice model attempts to extract more salt then +!! is actually available to it from the ocean. subroutine adjust_salt(h, tv, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(diabatic_aux_CS), intent(in) :: CS - -! Keep salinity from falling below a small but positive threshold -! This occurs when the ice model attempts to extract more salt then -! is actually available to it from the ocean. - -! Arguments: h - Layer thickness, in m. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! diabatic_driver_init. - real :: salt_add_col(SZI_(G),SZJ_(G)) ! The accumulated salt requirement - real :: S_min ! The minimum salinity - real :: mc ! A layer's mass kg m-2 . + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m + !! or kg m-2) + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to any + !! available thermodynamic fields. + type(diabatic_aux_CS), intent(in) :: CS !< control structure returned by + !! a previous call to diabatic_driver_init. + + ! local variables + real :: salt_add_col(SZI_(G),SZJ_(G)) !< The accumulated salt requirement + real :: S_min !< The minimum salinity + real :: mc !< A layer's mass kg m-2 . integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke @@ -410,33 +351,29 @@ subroutine adjust_salt(h, tv, G, GV, CS) end subroutine adjust_salt +!> Insert salt from brine rejection into the first layer below +!! the mixed layer which both contains mass and in which the +!! change in layer density remains stable after the addition +!! of salt via brine rejection. subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(thermo_var_ptrs), intent(inout) :: tv - type(forcing), intent(in) :: fluxes - integer, intent(in) :: nkmb - type(diabatic_aux_CS), intent(in) :: CS - real, intent(in) :: dt + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m + !! or kg m-2) + type(thermo_var_ptrs), intent(inout) :: tv !< structure containing pointers to + !! any available hermodynamic fields. + type(forcing), intent(in) :: fluxes !< tructure containing pointers + !! any possible forcing fields + integer, intent(in) :: nkmb !< number of layers in the mixed and + !! buffer layers + type(diabatic_aux_CS), intent(in) :: CS !< control structure returned by a + !! previous call to diabatic_driver_init. + real, intent(in) :: dt !< time step between calls to this + !! function (s) ?? integer, intent(in) :: id_brine_lay -! Insert salt from brine rejection into the first layer below -! the mixed layer which both contains mass and in which the -! change in layer density remains stable after the addition -! of salt via brine rejection. - -! Arguments: h - Layer thickness, in m. -! (in/out) tv - A structure containing pointers to any available -! thermodynamic fields. Absent fields have NULL ptrs. -! (in) fluxes = A structure containing pointers to any possible -! forcing fields; unused fields have NULL ptrs. -! (in) nkmb - The number of layers in the mixed and buffer layers. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - The control structure returned by a previous call to -! diabatic_driver_init. + ! local variables real :: salt(SZI_(G)) ! The amount of salt rejected from ! sea ice. [grams] real :: dzbr(SZI_(G)) ! cumulative depth over which brine is distributed @@ -456,7 +393,7 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke - if (.not.ASSOCIATED(fluxes%salt_flux)) return + if (.not.associated(fluxes%salt_flux)) return p_ref_cv(:) = tv%P_ref @@ -539,10 +476,9 @@ subroutine insert_brine(h, tv, G, GV, fluxes, nkmb, CS, dt, id_brine_lay) end subroutine insert_brine +!> Simple tri-diagnonal solver for T and S. +!! "Simple" means it only uses arrays hold, ea and eb. subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) -! Simple tri-diagnonal solver for T and S -! "Simple" means it only uses arrays hold, ea and eb - ! Arguments type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure integer, intent(in) :: is, ie, js, je @@ -579,35 +515,22 @@ subroutine triDiagTS(G, GV, is, ie, js, je, hold, ea, eb, T, S) enddo end subroutine triDiagTS - +!> Calculates u_h and v_h (velocities at thickness points), +!! optionally using the entrainments (in m) passed in as arguments. subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, ea, eb) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< The zonal velocity, in m s-1 real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< The meridional velocity, in m s-1 real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: u_h, v_h - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: ea, eb -! This subroutine calculates u_h and v_h (velocities at thickness -! points), optionally using the entrainments (in m) passed in as arguments. - -! Arguments: u - Zonal velocity, in m s-1. -! (in) v - Meridional velocity, in m s-1. -! (in) h - Layer thickness, in m or kg m-2. -! (out) u_h - The zonal velocity at thickness points after -! entrainment, in m s-1. -! (out) v_h - The meridional velocity at thickness points after -! entrainment, in m s-1. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in, opt) ea - The amount of fluid entrained from the layer above within -! this time step, in units of m or kg m-2. Omitting ea is the -! same as setting it to 0. -! (in, opt) eb - The amount of fluid entrained from the layer below within -! this time step, in units of m or kg m-2. Omitting eb is the -! same as setting it to 0. ea and eb must either be both -! present or both absent. - + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: u_h, v_h !< zonal and meridional velocity at thickness + !! points entrainment, in m s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in), optional :: ea, eb !< The amount of fluid entrained + !! from the layer above within this time step + !! , in units of m or kg m-2. Omitting ea is the + !! same as setting it to 0. + + ! local variables real :: b_denom_1 ! The first term in the denominator of b1 in m or kg m-2. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected, in m or kg m-2. @@ -739,7 +662,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, dia if (id_N2>0) then do i=is,ie pRef_N2(i) = pRef_N2(i) + GV%g_Earth * GV%Rho0 * h(i,j,k) * GV%H_to_m ! Boussinesq approximation!!!! ????? - !### This should be: pRef_N2(i) = pRev_N2(i) + GV%g_Earth * GV%H_to_kg_m2 * h(i,j,k) ! This might change answers at roundoff. + !### This should be: pRef_N2(i) = pRev_N2(i) + GV%g_Earth * GV%H_to_kg_m2 * h(i,j,k) + !### This might change answers at roundoff. enddo call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_N2, rhoAtK, is, ie-is+1, tv%eqn_of_state) do i=is,ie @@ -750,7 +674,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, dia !### It looks to me like there is bad logic here. - RWH ! Use pressure at the bottom of the upper layer used in calculating d/dz rho pRef_N2(i) = pRef_N2(i) + GV%g_Earth * GV%Rho0 * h(i,j,k) * GV%H_to_m ! Boussinesq approximation!!!! ????? - !### This line should be: pRef_N2(i) = pRev_N2(i) + GV%g_Earth * GV%H_to_kg_m2 * h(i,j,k) ! This might change answers at roundoff. + !### This line should be: pRef_N2(i) = pRev_N2(i) + GV%g_Earth * GV%H_to_kg_m2 * h(i,j,k) + !### This might change answers at roundoff. endif if (d1(i)>0. .and. dK(i)-d1(i)>=dz_subML) then subMLN2(i,j) = GV%g_Earth/ GV%Rho0 * (rho1(i)-rhoAtK(i)) / (d1(i) - dK(i)) @@ -861,7 +786,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ! Only apply forcing if fluxes%sw is associated. - if (.not.ASSOCIATED(fluxes%sw)) return + if (.not.associated(fluxes%sw)) return #define _OLD_ALG_ nsw = optics%nbands @@ -1043,13 +968,13 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & dTemp = dTemp + dThickness*Temp_in ! Diagnostics of heat content associated with mass fluxes - if (ASSOCIATED(fluxes%heat_content_massin)) & + if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & T2d(i,k) * max(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt - if (ASSOCIATED(fluxes%heat_content_massout)) & + if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & T2d(i,k) * min(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt - if (ASSOCIATED(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T2d(i,k) * dThickness * GV%H_to_kg_m2 ! Determine the energetics of river mixing before updating the state. @@ -1123,13 +1048,13 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & dTemp = dTemp + dThickness*T2d(i,k) ! Diagnostics of heat content associated with mass fluxes - if (ASSOCIATED(fluxes%heat_content_massin)) & + if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) + & tv%T(i,j,k) * max(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt - if (ASSOCIATED(fluxes%heat_content_massout)) & + if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) + & tv%T(i,j,k) * min(0.,dThickness) * GV%H_to_kg_m2 * fluxes%C_p * Idt - if (ASSOCIATED(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & + if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & tv%T(i,j,k) * dThickness * GV%H_to_kg_m2 !NOTE tv%T should be T2d @@ -1164,7 +1089,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & enddo ! k ! Check if trying to apply fluxes over land points - elseif((abs(netHeat(i))+abs(netSalt(i))+abs(netMassIn(i))+abs(netMassOut(i)))>0.) then + elseif ((abs(netHeat(i))+abs(netSalt(i))+abs(netMassIn(i))+abs(netMassOut(i)))>0.) then if (.not. CS%ignore_fluxes_over_land) then call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (land)') @@ -1199,7 +1124,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! Save temperature before increment with SW heating ! and initialize CS%penSWflux_diag to zero. - if(CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then + if (CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then do k=1,nz ; do i=is,ie CS%penSW_diag(i,j,k) = T2d(i,k) CS%penSWflux_diag(i,j,k) = 0.0 @@ -1231,7 +1156,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! Diagnose heating (W/m2) applied to a grid cell from SW penetration ! Also diagnose the penetrative SW heat flux at base of layer. - if(CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then + if (CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then ! convergence of SW into a layer do k=1,nz ; do i=is,ie @@ -1244,7 +1169,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! CS%penSWflux_diag(i,j,k=kbot+1) is zero, since assume no SW penetrates rock. ! CS%penSWflux_diag = rsdo and CS%penSW_diag = rsdoabsorb ! rsdoabsorb(k) = rsdo(k) - rsdo(k+1), so that rsdo(k) = rsdo(k+1) + rsdoabsorb(k) - if(CS%id_penSWflux_diag > 0) then + if (CS%id_penSWflux_diag > 0) then do k=nz,1,-1 ; do i=is,ie CS%penSWflux_diag(i,j,k) = CS%penSW_diag(i,j,k) + CS%penSWflux_diag(i,j,k+1) enddo ; enddo @@ -1253,7 +1178,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & endif ! Fill CS%nonpenSW_diag - if(CS%id_nonpenSW_diag > 0) then + if (CS%id_nonpenSW_diag > 0) then do i=is,ie CS%nonpenSW_diag(i,j) = nonpenSW(i) enddo @@ -1314,26 +1239,20 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & end subroutine applyBoundaryFluxesInOut +!> Initializes this module. subroutine diabatic_aux_init(Time, G, GV, param_file, diag, CS, useALEalgorithm, use_ePBL) type(time_type), intent(in) :: Time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), target, intent(inout) :: diag - type(diabatic_aux_CS), pointer :: CS - logical, intent(in) :: useALEalgorithm - logical, intent(in) :: use_ePBL - -! Arguments: -! (in) Time = current model time -! (in) G = ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) param_file = structure indicating the open file to parse for parameter values -! (in) diag = structure used to regulate diagnostic output -! (in/out) CS = pointer set to point to the control structure for this module -! (in) use_ePBL = If true, use the implicit energetics planetary boundary -! layer scheme to determine the diffusivity in the -! surface boundary layer. + type(diag_ctrl), target, intent(inout) :: diag !< structure used to regulate diagnostic output + type(diabatic_aux_CS), pointer :: CS !< pointer set to point to the ontrol structure for + !! this module + logical, intent(in) :: useALEalgorithm !< If True, uses ALE. + logical, intent(in) :: use_ePBL !< If true, use the implicit energetics + !! planetary boundary layer scheme to determine the + !! diffusivity in the surface boundary layer. + ! local variables type(vardesc) :: vd ! This "include" declares and sets the variable "version". @@ -1456,4 +1375,48 @@ subroutine diabatic_aux_end(CS) end subroutine diabatic_aux_end +!> \namespace MOM_diabatic_aux +!! +!! This module contains the subroutines that, along with the * +!! subroutines that it calls, implements diapycnal mass and momentum * +!! fluxes and a bulk mixed layer. The diapycnal diffusion can be * +!! used without the bulk mixed layer. * +!! * +!! diabatic first determines the (diffusive) diapycnal mass fluxes * +!! based on the convergence of the buoyancy fluxes within each layer. * +!! The dual-stream entrainment scheme of MacDougall and Dewar (JPO, * +!! 1997) is used for combined diapycnal advection and diffusion, * +!! calculated implicitly and potentially with the Richardson number * +!! dependent mixing, as described by Hallberg (MWR, 2000). Diapycnal * +!! advection is fundamentally the residual of diapycnal diffusion, * +!! so the fully implicit upwind differencing scheme that is used is * +!! entirely appropriate. The downward buoyancy flux in each layer * +!! is determined from an implicit calculation based on the previously * +!! calculated flux of the layer above and an estimated flux in the * +!! layer below. This flux is subject to the following conditions: * +!! (1) the flux in the top and bottom layers are set by the boundary * +!! conditions, and (2) no layer may be driven below an Angstrom thick-* +!! ness. If there is a bulk mixed layer, the buffer layer is treat- * +!! ed as a fixed density layer with vanishingly small diffusivity. * +!! * +!! diabatic takes 5 arguments: the two velocities (u and v), the * +!! thicknesses (h), a structure containing the forcing fields, and * +!! the length of time over which to act (dt). The velocities and * +!! thickness are taken as inputs and modified within the subroutine. * +!! There is no limit on the time step. * +!! * +!! A small fragment of the grid is shown below: * +!! * +!! j+1 x ^ x ^ x At x: q * +!! j+1 > o > o > At ^: v * +!! j x ^ x ^ x At >: u * +!! j > o > o > At o: h, T, S, buoy, ustar, ea, eb, etc. * +!! j-1 x ^ x ^ x * +!! i-1 i i+1 At x & ^: * +!! i i+1 At > & o: * +!! * +!! The boundaries always run through q grid points (x). * +!! * +!!********+*********+*********+*********+*********+*********+*********+** + end module MOM_diabatic_aux diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 284b209932..f253687821 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -10,6 +10,7 @@ module MOM_diabatic_driver use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE use MOM_CVMix_shear, only : CVMix_shear_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS use MOM_diabatic_aux, only : make_frazil, adjust_salt, insert_brine, differential_diffuse_T_S, triDiagTS use MOM_diabatic_aux, only : find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut @@ -49,9 +50,9 @@ module MOM_diabatic_driver use MOM_internal_tides, only : propagate_int_tide use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used -use MOM_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate -use MOM_KPP, only : KPP_end, KPP_get_BLD -use MOM_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln +use MOM_CVMix_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate +use MOM_CVMix_KPP, only : KPP_end, KPP_get_BLD +use MOM_CVMix_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln use MOM_opacity, only : opacity_init, set_opacity, opacity_end, opacity_CS use MOM_regularize_layers, only : regularize_layers, regularize_layers_init, regularize_layers_CS use MOM_set_diffusivity, only : set_diffusivity, set_BBL_TKE @@ -69,6 +70,7 @@ module MOM_diabatic_driver use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_speed, only : wave_speeds use time_manager_mod, only : increment_time ! for testing itides (BDM) +use MOM_wave_interface, only : wave_parameters_CS implicit none ; private @@ -81,9 +83,10 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init +public legacy_diabatic !> Control structure for this module -type, public:: diabatic_CS ; private +type, public:: diabatic_CS; private logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with !! nkml sublayers (and additional buffer layers). logical :: use_energetic_PBL !< If true, use the implicit energetics planetary @@ -93,6 +96,7 @@ module MOM_diabatic_driver !! shear-driven diapycnal diffusivity. logical :: use_CVMix_shear !< If true, use the CVMix module to find the !! shear-driven diapycnal diffusivity. + logical :: use_CVMix_ddiff !< If true, use the CVMix double diffusion module. logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. logical :: use_CVMix_conv !< If true, use the CVMix module to get enhanced !! mixing due to convection. @@ -166,8 +170,9 @@ module MOM_diabatic_driver integer :: id_cg1 = -1 ! diag handle for mode-1 speed (BDM) integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds (BDM) - integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_wd = -1 - integer :: id_ea = -1, id_eb = -1, id_Kd_z = -1 + integer :: id_wd = -1, id_ea = -1, id_eb = -1 ! used by layer diabatic + integer :: id_dudt_dia = -1, id_dvdt_dia = -1, id_ea_s = -1, id_eb_s = -1 + integer :: id_ea_t = -1, id_eb_t = -1, id_Kd_z = -1 integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_interface = -1, id_Kd_ePBL = -1 integer :: id_Tdif_z = -1, id_Tadv_z = -1, id_Sdif_z = -1, id_Sadv_z = -1 integer :: id_Tdif = -1, id_Tadv = -1, id_Sdif = -1, id_Sadv = -1 @@ -251,13 +256,14 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, GV, CS) +subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, CS, WAVES) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity (m/s) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness (m for Bouss / kg/m2 for non-Bouss) - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields; + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< active mixed layer depth type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -270,6 +276,890 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G real, intent(in) :: dt !< time increment (seconds) type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & + ea_s, & ! amount of fluid entrained from the layer above within + ! one time step (m for Bouss, kg/m^2 for non-Bouss) + eb_s, & ! amount of fluid entrained from the layer below within + ! one time step (m for Bouss, kg/m^2 for non-Bouss) + ea_t, & ! amount of fluid entrained from the layer above within + ! one time step (m for Bouss, kg/m^2 for non-Bouss) + eb_t, & ! amount of fluid entrained from the layer below within + ! one time step (m for Bouss, kg/m^2 for non-Bouss) + Kd, & ! diapycnal diffusivity of layers (m^2/sec) + h_orig, & ! initial layer thicknesses (m for Bouss, kg/m^2 for non-Bouss) + h_prebound, & ! initial layer thicknesses (m for Bouss, kg/m^2 for non-Bouss) +! hold, & ! layer thickness before diapycnal entrainment, and later + ! the initial layer thicknesses (if a mixed layer is used), + ! (m for Bouss, kg/m^2 for non-Bouss) + dSV_dT, & ! The partial derivatives of specific volume with temperature + dSV_dS, & ! and salinity in m^3/(kg K) and m^3/(kg ppt). + cTKE, & ! convective TKE requirements for each layer in J/m^2. + u_h, & ! zonal and meridional velocities at thickness points after + v_h ! entrainment (m/s) + + real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & + cn ! baroclinic gravity wave speeds (formerly cg1 - BDM) + + real, dimension(SZI_(G),SZJ_(G)) :: & + Rcv_ml, & ! coordinate density of mixed layer, used for applying sponges + SkinBuoyFlux! 2d surface buoyancy flux (m2/s3), used by ePBL + real, dimension(SZI_(G),SZJ_(G),G%ke) :: h_diag ! diagnostic array for thickness + real, dimension(SZI_(G),SZJ_(G),G%ke) :: temp_diag ! diagnostic array for temp + real, dimension(SZI_(G),SZJ_(G),G%ke) :: saln_diag ! diagnostic array for salinity + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn + real, dimension(SZI_(G),SZJ_(G)) :: TKE_itidal_input_test ! override of energy input for testing (BDM) + + real :: net_ent ! The net of ea-eb at an interface. + + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target :: & + ! These are targets so that the space can be shared with eaml & ebml. + eatr, & ! The equivalent of ea and eb for tracers, which differ from ea and + ebtr ! eb in that they tend to homogenize tracers in massless layers + ! near the boundaries (m for Bouss and kg/m^2 for non-Bouss) + + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), target :: & + Kd_int, & ! diapycnal diffusivity of interfaces (m^2/s) + Kd_heat, & ! diapycnal diffusivity of heat (m^2/s) + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers (m^2/s) + Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces (m^2/s) + eta, & ! Interface heights before diapycnal mixing, in m. + Tdif_flx, & ! diffusive diapycnal heat flux across interfaces (K m/s) + Tadv_flx, & ! advective diapycnal heat flux across interfaces (K m/s) + Sdif_flx, & ! diffusive diapycnal salt flux across interfaces (ppt m/s) + Sadv_flx ! advective diapycnal salt flux across interfaces (ppt m/s) + + ! The following 5 variables are only used with a bulk mixed layer. + real, pointer, dimension(:,:,:) :: & + eaml, & ! The equivalent of ea and eb due to mixed layer processes, + ebml ! (m for Bouss and kg/m^2 for non-Bouss). These will be + ! pointers to eatr and ebtr so as to reuse the memory as + ! the arrays are not needed at the same time. + + integer :: kb(SZI_(G),SZJ_(G)) ! index of the lightest layer denser + ! than the buffer laye (nondimensional) + + real :: p_ref_cv(SZI_(G)) ! Reference pressure for the potential + ! density which defines the coordinate + ! variable, set to P_Ref, in Pa. + + logical :: in_boundary(SZI_(G)) ! True if there are no massive layers below, + ! where massive is defined as sufficiently thick that + ! the no-flux boundary conditions have not restricted + ! the entrainment - usually sqrt(Kd*dt). + + real :: b_denom_1 ! The first term in the denominator of b1 + ! (m for Bouss, kg/m^2 for non-Bouss) + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected + ! (m for Bouss and kg/m^2 for non-Bouss) + real :: h_neglect2 ! h_neglect^2 (m^2 for Bouss, kg^2/m^4 for non-Bouss) + real :: add_ent ! Entrainment that needs to be added when mixing tracers + ! (m for Bouss and kg/m^2 for non-Bouss) + real :: eaval ! eaval is 2*ea at velocity grid points (m for Bouss, kg/m^2 for non-Bouss) + real :: hval ! hval is 2*h at velocity grid points (m for Bouss, kg/m^2 for non-Bouss) + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness (m for Bouss, kg/m^2 for non-Bouss) + real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is + ! coupled to the bottom within a timestep (m) + + real :: htot(SZIB_(G)) ! The summed thickness from the bottom, in m. + real :: b1(SZIB_(G)), d1(SZIB_(G)) ! b1, c1, and d1 are variables used by the + real :: c1(SZIB_(G),SZK_(G)) ! tridiagonal solver. + + real :: Ent_int ! The diffusive entrainment rate at an interface + ! (H units = m for Bouss, kg/m^2 for non-Bouss). + real :: dt_mix ! amount of time over which to apply mixing (seconds) + real :: Idt ! inverse time step (1/s) + + type(p3d) :: z_ptrs(7) ! pointers to diagnostics to be interpolated to depth + integer :: num_z_diags ! number of diagnostics to be interpolated to depth + integer :: z_ids(7) ! id numbers of diagnostics to be interpolated to depth + 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, nkmb, m + + integer :: ig, jg ! global indices for testing testing itide point source (BDM) + logical :: avg_enabled ! for testing internal tides (BDM) + real :: Kd_add_here ! An added diffusivity in m2/s + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + nkmb = GV%nk_rho_varies + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 + + if (nz == 1) return + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") + + if (.not. (CS%useALEalgorithm)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "The ALE algorithm must be enabled when using MOM_diabatic_driver.") + + ! Offer diagnostics of various state varables 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) + if (CS%id_h_predia > 0) call post_data(CS%id_h_predia, h, CS%diag) + if (CS%id_T_predia > 0) call post_data(CS%id_T_predia, tv%T, CS%diag) + if (CS%id_S_predia > 0) call post_data(CS%id_S_predia, tv%S, CS%diag) + if (CS%id_e_predia > 0) then + call find_eta(h, tv, GV%g_Earth, G, GV, eta) + call post_data(CS%id_e_predia, eta, CS%diag) + endif + + + ! set equivalence between the same bits of memory for these arrays + eaml => eatr ; ebml => ebtr + + ! inverse time step + Idt = 1.0 / dt + + if (.not. associated(CS)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & + "Module must be initialized before it is used.") + + if (CS%debug) then + call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("Start of diabatic", fluxes, G, haloshift=0) + endif + if (CS%debugConservation) call MOM_state_stats('Start of diabatic', u, v, h, tv%T, tv%S, G) + + if (CS%debug_energy_req) & + call diapyc_energy_req_test(h, dt, tv, G, GV, CS%diapyc_en_rec_CSp) + + + call cpu_clock_begin(id_clock_set_diffusivity) + call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, CS%set_diff_CSp) + call cpu_clock_end(id_clock_set_diffusivity) + + ! Frazil formation keeps the temperature above the freezing point. + ! make_frazil is deliberately called at both the beginning and at + ! the end of the diabatic processes. + if (associated(tv%T) .AND. associated(tv%frazil)) then + ! For frazil diagnostic, the first call covers the first half of the time step + call enable_averaging(0.5*dt, Time_end - set_time(int(floor(0.5*dt+0.5))), CS%diag) + if (CS%frazil_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + + if (associated(fluxes%p_surf_full)) then + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + else + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + endif + if (showCallTree) call callTree_waypoint("done with 1st make_frazil (diabatic)") + + if (CS%frazil_tendency_diag) then + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, CS) + if (CS%id_frazil_h > 0) call post_data(CS%id_frazil_h, h, CS%diag) + endif + call disable_averaging(CS%diag) + endif !associated(tv%T) .AND. associated(tv%frazil) + + ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep + call enable_averaging(dt, Time_end, CS%diag) + if (CS%debugConservation) call MOM_state_stats('1st make_frazil', u, v, h, tv%T, tv%S, G) + + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then +!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_orig,h,eaml,ebml) + do k=1,nz ; do j=js,je ; do i=is,ie + h_orig(i,j,k) = h(i,j,k) ; eaml(i,j,k) = 0.0 ; ebml(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + if (CS%use_geothermal) then + call cpu_clock_begin(id_clock_geothermal) + call geothermal(h, tv, dt, eaml, ebml, G, GV, CS%geothermal_CSp) + call cpu_clock_end(id_clock_geothermal) + if (showCallTree) call callTree_waypoint("geothermal (diabatic)") + if (CS%debugConservation) call MOM_state_stats('geothermal', u, v, h, tv%T, tv%S, G) + endif + + ! Whenever thickness changes let the diag manager know, target grids + ! for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! Set_opacity estimates the optical properties of the water column. + ! It will need to be modified later to include information about the + ! biological properties and layer thicknesses. + if (associated(CS%optics)) & + call set_opacity(CS%optics, fluxes, G, GV, CS%opacity_CSp) + + if (CS%debug) & + call MOM_state_chksum("before find_uv_at_h", u, v, h, G, GV, haloshift=0) + + if (CS%use_kappa_shear .or. CS%use_CVMix_shear) then + if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then + call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, eaml, ebml) + if (CS%debug) then + call hchksum(eaml, "after find_uv_at_h eaml",G%HI, scale=GV%H_to_m) + call hchksum(ebml, "after find_uv_at_h ebml",G%HI, scale=GV%H_to_m) + endif + else + call find_uv_at_h(u, v, h, u_h, v_h, G, GV) + endif + if (showCallTree) call callTree_waypoint("done with find_uv_at_h (diabatic)") + endif + + if (CS%use_int_tides) then + ! This block provides an interface for the unresolved low-mode internal + ! tide module (BDM). + + ! PROVIDE ENERGY DISTRIBUTION (calculate time-varying energy source) + call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, & + CS%int_tide_input_CSp) + ! CALCULATE MODAL VELOCITIES + cn(:,:,:) = 0.0 + if (CS%uniform_cg) then + ! SET TO CONSTANT VALUE TO TEST PROPAGATE CODE + do m=1,CS%nMode ; cn(:,:,m) = CS%cg_test ; enddo + else + call wave_speeds(h, tv, G, GV, CS%nMode, cn, full_halos=.true.) + ! uncomment the lines below for a hard-coded cn that changes linearly with latitude + !do j=G%jsd,G%jed ; do i=G%isd,G%ied + ! cn(i,j,:) = ((7.-1.)/14000000.)*G%geoLatBu(i,j) + (1.-((7.-1.)/14000000.)*-7000000.) + !enddo ; enddo + endif + + if (CS%int_tide_source_test) then + ! BUILD 2D ARRAY WITH POINT SOURCE FOR TESTING + ! This block of code should be moved into set_int_tide_input. -RWH + TKE_itidal_input_test(:,:) = 0.0 + avg_enabled = query_averaging_enabled(CS%diag,time_end=CS%time_end) + if (CS%time_end <= CS%time_max_source) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + !INPUT ARBITRARY ENERGY POINT SOURCE + if ((G%idg_offset + i == CS%int_tide_source_x) .and. & + (G%jdg_offset + j == CS%int_tide_source_y)) then + TKE_itidal_input_test(i,j) = 1.0 + endif + enddo ; enddo + endif + ! CALL ROUTINE USING PRESCRIBED KE FOR TESTING + call propagate_int_tide(h, tv, cn, TKE_itidal_input_test, & + CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, CS%int_tide_CSp) + else + ! CALL ROUTINE USING CALCULATED KE INPUT + call propagate_int_tide(h, tv, cn, CS%int_tide_input%TKE_itidal_input, & + CS%int_tide_input%tideamp, CS%int_tide_input%Nb, dt, G, GV, CS%int_tide_CSp) + endif + if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") + endif ! end CS%use_int_tides + + call cpu_clock_begin(id_clock_set_diffusivity) + ! Sets: Kd, Kd_int, visc%Kd_extra_T, visc%Kd_extra_S + ! Also changes: visc%Kd_shear, visc%Kv_slow and visc%TKE_turb (not clear that TKE_turb is used as input ???? + call set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, CS%optics, visc, dt, G, GV, CS%set_diff_CSp, Kd, Kd_int) + call cpu_clock_end(id_clock_set_diffusivity) + if (showCallTree) call callTree_waypoint("done with set_diffusivity (diabatic)") + + ! Set diffusivities for heat and salt separately + +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,Kd_heat) +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,k) = Kd_int(i,j,k) + Kd_heat(i,j,k) = Kd_int(i,j,k) + enddo ; enddo ; enddo + ! Add contribution from double diffusion + if (associated(visc%Kd_extra_S)) then +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_salt(i,j,k) = Kd_salt(i,j,k) + visc%Kd_extra_S(i,j,k) + enddo ; enddo ; enddo + endif + if (associated(visc%Kd_extra_T)) then +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_heat(i,j,k) = Kd_heat(i,j,k) + visc%Kd_extra_T(i,j,k) + enddo ; enddo ; enddo + endif +!$OMP end parallel + + if (CS%debug) then + call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after set_diffusivity ", tv, G) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat",G%HI,haloshift=0) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt",G%HI,haloshift=0) + endif + + if (CS%useKPP) then + call cpu_clock_begin(id_clock_kpp) + ! total vertical viscosity in the interior is represented via visc%Kv_shear + do k=1,nz+1 ; do j=js,je ; do i=is,ie + visc%Kv_shear(i,j,k) = visc%Kv_shear(i,j,k) + visc%Kv_slow(i,j,k) + enddo ; enddo ; enddo + + ! KPP needs the surface buoyancy flux but does not update state variables. + ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. + ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux + ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! unlike other instances where the fluxes are integrated in time over a time-step. + call calculateBuoyancyFlux2d(G, GV, fluxes, CS%optics, h, tv%T, tv%S, tv, & + CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + + call KPP_compute_BLD(CS%KPP_CSp, G, GV, h, tv%T, tv%S, u, v, tv%eqn_of_state, & + fluxes%ustar, CS%KPP_buoy_flux) + + call KPP_calculate(CS%KPP_CSp, G, GV, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,G,Kd_heat,Hml) + + if (associated(Hml)) then + call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) + call pass_var(Hml, G%domain, halo=1) + endif + + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") + if (CS%debug) then + call MOM_state_chksum("after KPP", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("after KPP", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after KPP", tv, G) + call hchksum(Kd_heat, "after KPP Kd_heat",G%HI,haloshift=0) + call hchksum(Kd_salt, "after KPP Kd_salt",G%HI,haloshift=0) + endif + + endif ! endif for KPP + + + if (CS%useKPP) then + call cpu_clock_begin(id_clock_kpp) + if (CS%debug) then + call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat",G%HI,haloshift=0) + call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar",G%HI,haloshift=0) + endif + ! Apply non-local transport of heat and salt + ! Changes: tv%T, tv%S + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, dt, tv%T, tv%C_p) + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, dt, tv%S) + call cpu_clock_end(id_clock_kpp) + if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") + if (CS%debugConservation) call MOM_state_stats('KPP_applyNonLocalTransport', u, v, h, tv%T, tv%S, G) + + if (CS%debug) then + call MOM_state_chksum("after KPP_applyNLT ", u, v, h, G, GV, haloshift=0) + call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G) + endif + endif ! endif for KPP + + ! This is the "old" method for applying differential diffusion. + ! Changes: tv%T, tv%S + if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T) .and. .not. & + CS%use_CVMix_ddiff) then + + call cpu_clock_begin(id_clock_differential_diff) + call differential_diffuse_T_S(h, tv, visc, dt, G, GV) + call cpu_clock_end(id_clock_differential_diff) + + if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") + if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G) + + ! increment heat and salt diffusivity. + ! CS%useKPP==.true. already has extra_T and extra_S included + if (.not. CS%useKPP) then +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,visc,Kd_heat) +!$OMP do + do K=2,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,K) = Kd_heat(i,j,K) + visc%Kd_extra_T(i,j,K) + Kd_salt(i,j,K) = Kd_salt(i,j,K) + visc%Kd_extra_S(i,j,K) + enddo ; enddo ; enddo +!$OMP end parallel + endif + + endif + + ! Calculate vertical mixing due to convection (computed via CVMix) + if (CS%use_CVMix_conv) then + call calculate_CVMix_conv(h, tv, G, GV, CS%CVMix_conv_csp, Hml) + ! Increment vertical diffusion and viscosity due to convection +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,visc,CS,Kd_heat) +!$OMP do + do k=1,nz+1 ; do j=js,je ; do i=is,ie + Kd_heat(i,j,k) = Kd_heat(i,j,k) + CS%CVMix_conv_csp%kd_conv(i,j,k) + Kd_salt(i,j,k) = Kd_salt(i,j,k) + CS%CVMix_conv_csp%kd_conv(i,j,k) + if (CS%useKPP) then + visc%Kv_shear(i,j,k) = visc%Kv_shear(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) + else + visc%Kv_slow(i,j,k) = visc%Kv_slow(i,j,k) + CS%CVMix_conv_csp%kv_conv(i,j,k) + endif + enddo ; enddo ; enddo +!$OMP end parallel + endif + + ! Save fields before boundary forcing is applied for tendency diagnostics + if (CS%boundary_forcing_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + h_diag(i,j,k) = h(i,j,k) + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! Apply forcing + call cpu_clock_begin(id_clock_remap) + + ! Changes made to following fields: h, tv%T and tv%S. + do k=1,nz ; do j=js,je ; do i=is,ie + h_prebound(i,j,k) = h(i,j,k) + enddo ; enddo ; enddo + if (CS%use_energetic_PBL) then + + skinbuoyflux(:,:) = 0.0 + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, dt, fluxes, CS%optics, & + h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + + if (CS%debug) then + call hchksum(ea_t, "after applyBoundaryFluxes ea_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "after applyBoundaryFluxes eb_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "after applyBoundaryFluxes ea_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "after applyBoundaryFluxes eb_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(cTKE, "after applyBoundaryFluxes cTKE",G%HI,haloshift=0) + call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT",G%HI,haloshift=0) + call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS",G%HI,haloshift=0) + endif + + call find_uv_at_h(u, v, h, u_h, v_h, G, GV) + call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, & + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) + + ! If visc%MLD exists, copy the ePBL's MLD into it + if (associated(visc%MLD)) then + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, visc%MLD, G) + call pass_var(visc%MLD, G%domain, halo=1) + Hml(:,:) = visc%MLD(:,:) + endif + + ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. + do K=2,nz ; do j=js,je ; do i=is,ie + if (CS%ePBL_is_additive) then + Kd_add_here = Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + Kd_ePBL(i,j,K) + else + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), Kd_ePBL(i,j,K)) + endif + + Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_add_here + Kd_salt(i,j,K) = Kd_salt(i,j,K) + Kd_add_here + + enddo ; enddo ; enddo + + if (CS%debug) then + call hchksum(ea_t, "after ePBL ea_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "after ePBL eb_t",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "after ePBL ea_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "after ePBL eb_s",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL",G%HI,haloshift=0) + endif + + else + call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, dt, fluxes, CS%optics, & + h, tv, CS%aggregate_FW_forcing, & + CS%evap_CFL_limit, CS%minimum_forcing_depth) + + endif ! endif for CS%use_energetic_PBL + + ! diagnose the tendencies due to boundary forcing + ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme + ! so all tendency diagnostics need to be posted on h_diag, and grids rebuilt afterwards + if (CS%boundary_forcing_tendency_diag) then + call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, CS) + if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h = h_diag) + endif + ! Boundary fluxes may have changed T, S, and h + call diag_update_remap_grids(CS%diag) + call cpu_clock_end(id_clock_remap) + if (CS%debug) then + call MOM_forcing_chksum("after applyBoundaryFluxes ", fluxes, G, haloshift=0) + call MOM_thermovar_chksum("after applyBoundaryFluxes ", tv, G) + call MOM_state_chksum("after applyBoundaryFluxes ", u, v, h, G, GV, haloshift=0) + endif + if (showCallTree) call callTree_waypoint("done with applyBoundaryFluxes (diabatic)") + if (CS%debugConservation) call MOM_state_stats('applyBoundaryFluxes', u, v, h, tv%T, tv%S, G) + + if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") + if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G) + + ! calculate change in temperature & salinity due to dia-coordinate surface diffusion + if (associated(tv%T)) then + + if (CS%debug) then + call hchksum(ea_t, "before triDiagTS ea_t ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_t, "before triDiagTS eb_t ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(ea_s, "before triDiagTS ea_s ",G%HI,haloshift=0, scale=GV%H_to_m) + call hchksum(eb_s, "before triDiagTS eb_s ",G%HI,haloshift=0, scale=GV%H_to_m) + endif + + call cpu_clock_begin(id_clock_tridiag) + ! Keep salinity from falling below a small but positive threshold. + ! This constraint is needed for SIS1 ice model, which can extract + ! more salt than is present in the ocean. SIS2 does not suffer + ! from this limitation, in which case we can let salinity=0 and still + ! have salt conserved with SIS2 ice. So for SIS2, we can run with + ! BOUND_SALINITY=False in MOM.F90. + if (associated(tv%S) .and. associated(tv%salt_deficit)) & + call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) + + if (CS%diabatic_diff_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + saln_diag(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + + ! set ea_t=eb_t=Kd_heat and ea_s=eb_s=Kd_salt on interfaces for use in the + ! tri-diagonal solver. + + do j=js,je ; do i=is,ie + ea_t(i,j,1) = 0.; ea_s(i,j,1) = 0. + enddo ; enddo + +!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_neglect,h,ea_t,ea_s,GV,dt,Kd_salt,Kd_heat,eb_t,eb_s) & +!$OMP private(hval) + do k=2,nz ; do j=js,je ; do i=is,ie + hval=1.0/(h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) + ea_t(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_heat(i,j,k) + eb_t(i,j,k-1) = ea_t(i,j,k) + ea_s(i,j,k) = (GV%m_to_H**2) * dt * hval * Kd_salt(i,j,k) + eb_s(i,j,k-1) = ea_s(i,j,k) + enddo ; enddo ; enddo + do j=js,je ; do i=is,ie + eb_t(i,j,nz) = 0.; eb_s(i,j,nz) = 0. + enddo ; enddo + if (showCallTree) call callTree_waypoint("done setting ea_t,ea_s,eb_t,eb_s from Kd_heat" //& + "and Kd_salt (diabatic)") + + ! Initialize halo regions of ea, eb, and hold to default values. + !$OMP parallel do default(shared) + do k=1,nz + do i=is-1,ie+1 + ea_t(i,js-1,k) = 0.0 ; eb_t(i,js-1,k) = 0.0 + ea_s(i,js-1,k) = 0.0 ; eb_s(i,js-1,k) = 0.0 + ea_t(i,je+1,k) = 0.0 ; eb_t(i,je+1,k) = 0.0 + ea_s(i,je+1,k) = 0.0 ; eb_s(i,je+1,k) = 0.0 + enddo + do j=js,je + ea_t(is-1,j,k) = 0.0 ; eb_t(is-1,j,k) = 0.0 + ea_s(is-1,j,k) = 0.0 ; eb_s(is-1,j,k) = 0.0 + ea_t(ie+1,j,k) = 0.0 ; eb_t(ie+1,j,k) = 0.0 + ea_s(ie+1,j,k) = 0.0 ; eb_s(ie+1,j,k) = 0.0 + enddo + enddo + + ! Changes T and S via the tridiagonal solver; no change to h + call tracer_vertdiff(h, ea_t, eb_t, dt, tv%T, G, GV) + call tracer_vertdiff(h, ea_s, eb_s, dt, tv%S, G, GV) + + + ! In ALE-mode, layer thicknesses do not change. Therefore, we can use h below + if (CS%diabatic_diff_tendency_diag) then + call diagnose_diabatic_diff_tendency(tv, h, temp_diag, saln_diag, dt, G, GV, CS) + endif + call cpu_clock_end(id_clock_tridiag) + + if (showCallTree) call callTree_waypoint("done with triDiagTS (diabatic)") + + endif ! endif corresponding to if (associated(tv%T)) + + if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G) + + if (CS%debug) then + call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, haloshift=0) + call MOM_thermovar_chksum("after mixed layer ", tv, G) + endif + + ! Whenever thickness changes let the diag manager know, as the + ! target grids for vertical remapping may need to be regenerated. + call diag_update_remap_grids(CS%diag) + + ! diagnostics + if ((CS%id_Tdif > 0) .or. (CS%id_Tdif_z > 0) .or. & + (CS%id_Tadv > 0) .or. (CS%id_Tadv_z > 0)) then + do j=js,je ; do i=is,ie + Tdif_flx(i,j,1) = 0.0 ; Tdif_flx(i,j,nz+1) = 0.0 + Tadv_flx(i,j,1) = 0.0 ; Tadv_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Tdif_flx(i,j,K) = (Idt * 0.5*(ea_t(i,j,k) + eb_t(i,j,k-1))) * & + (tv%T(i,j,k-1) - tv%T(i,j,k)) + Tadv_flx(i,j,K) = (Idt * (ea_t(i,j,k) - eb_t(i,j,k-1))) * & + 0.5*(tv%T(i,j,k-1) + tv%T(i,j,k)) + enddo ; enddo ; enddo + endif + if ((CS%id_Sdif > 0) .or. (CS%id_Sdif_z > 0) .or. & + (CS%id_Sadv > 0) .or. (CS%id_Sadv_z > 0)) then + do j=js,je ; do i=is,ie + Sdif_flx(i,j,1) = 0.0 ; Sdif_flx(i,j,nz+1) = 0.0 + Sadv_flx(i,j,1) = 0.0 ; Sadv_flx(i,j,nz+1) = 0.0 + enddo ; enddo + !$OMP parallel do default(shared) + do K=2,nz ; do j=js,je ; do i=is,ie + Sdif_flx(i,j,K) = (Idt * 0.5*(ea_s(i,j,k) + eb_s(i,j,k-1))) * & + (tv%S(i,j,k-1) - tv%S(i,j,k)) + Sadv_flx(i,j,K) = (Idt * (ea_s(i,j,k) - eb_s(i,j,k-1))) * & + 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) + enddo ; enddo ; enddo + endif + + ! mixing of passive tracers from massless boundary layers to interior + call cpu_clock_begin(id_clock_tracers) + + if (CS%mix_boundary_tracers) then + Tr_ea_BBL = sqrt(dt*CS%Kd_BBL_tr) + !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) + do j=js,je + do i=is,ie + ebtr(i,j,nz) = eb_s(i,j,nz) + htot(i) = 0.0 + in_boundary(i) = (G%mask2dT(i,j) > 0.0) + enddo + do k=nz,2,-1 ; do i=is,ie + if (in_boundary(i)) then + htot(i) = htot(i) + h(i,j,k) + ! If diapycnal mixing has been suppressed because this is a massless + ! layer near the bottom, add some mixing of tracers between these + ! layers. This flux is based on the harmonic mean of the two + ! thicknesses, as this corresponds pretty closely (to within + ! differences in the density jumps between layers) with what is done + ! in the calculation of the fluxes in the first place. Kd_min_tr + ! should be much less than the values that have been set in Kd, + ! perhaps a molecular diffusivity. + add_ent = ((dt * CS%Kd_min_tr) * GV%m_to_H**2) * & + ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & + (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + 0.5*(ea_s(i,j,k) + eb_s(i,j,k-1)) + if (htot(i) < Tr_ea_BBL) then + add_ent = max(0.0, add_ent, & + (Tr_ea_BBL - htot(i)) - min(ea_s(i,j,k),eb_s(i,j,k-1))) + elseif (add_ent < 0.0) then + add_ent = 0.0 ; in_boundary(i) = .false. + endif + + ebtr(i,j,k-1) = eb_s(i,j,k-1) + add_ent + eatr(i,j,k) = ea_s(i,j,k) + add_ent + else + ebtr(i,j,k-1) = eb_s(i,j,k-1) ; eatr(i,j,k) = ea_s(i,j,k) + endif + + if (associated(visc%Kd_extra_S)) then ; if (visc%Kd_extra_S(i,j,k) > 0.0) then + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%m_to_H**2) / & + (0.5 * (h(i,j,k-1) + h(i,j,k)) + & + h_neglect) + ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent + eatr(i,j,k) = eatr(i,j,k) + add_ent + endif ; endif + enddo ; enddo + do i=is,ie ; eatr(i,j,1) = ea_s(i,j,1) ; enddo + + enddo + + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + ! so hold should be h_orig + call call_tracer_column_fns(h_prebound, h, ea_s, eb_s, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) + + elseif (associated(visc%Kd_extra_S)) then ! extra diffusivity for passive tracers + + do j=js,je ; do i=is,ie + ebtr(i,j,nz) = eb_s(i,j,nz) ; eatr(i,j,1) = ea_s(i,j,1) + enddo ; enddo + !$OMP parallel do default(shared) private(add_ent) + do k=nz,2,-1 ; do j=js,je ; do i=is,ie + if (visc%Kd_extra_S(i,j,k) > 0.0) then + add_ent = ((dt * visc%Kd_extra_S(i,j,k)) * GV%m_to_H**2) / & + (0.5 * (h(i,j,k-1) + h(i,j,k)) + & + h_neglect) + else + add_ent = 0.0 + endif + ebtr(i,j,k-1) = eb_s(i,j,k-1) + add_ent + eatr(i,j,k) = ea_s(i,j,k) + add_ent + enddo ; enddo ; enddo + + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug,& + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) + + else + ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied + call call_tracer_column_fns(h_prebound, h, eatr, ebtr, fluxes, Hml, dt, G, GV, tv, & + CS%optics, CS%tracer_flow_CSp, CS%debug, & + evap_CFL_limit = CS%evap_CFL_limit, & + minimum_forcing_depth = CS%minimum_forcing_depth) + + endif ! (CS%mix_boundary_tracers) + + call cpu_clock_end(id_clock_tracers) + + ! sponges + if (CS%use_sponge) then + call cpu_clock_begin(id_clock_sponge) + if (associated(CS%ALE_sponge_CSp)) then + ! ALE sponge + call apply_ALE_sponge(h, dt, G, CS%ALE_sponge_CSp, CS%Time) + endif + + call cpu_clock_end(id_clock_sponge) + if (CS%debug) then + call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, haloshift=0) + call MOM_thermovar_chksum("apply_sponge ", tv, G) + endif + endif ! CS%use_sponge + + call cpu_clock_begin(id_clock_pass) + if (G%symmetric) then ; dir_flag = To_All+Omit_Corners + else ; dir_flag = To_West+To_South+Omit_Corners ; endif + call create_group_pass(CS%pass_hold_eb_ea, eb_t, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, eb_s, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, ea_t, G%Domain, dir_flag, halo=1) + call create_group_pass(CS%pass_hold_eb_ea, ea_s, G%Domain, dir_flag, halo=1) + call do_group_pass(CS%pass_hold_eb_ea, G%Domain) + ! visc%Kv_shear and visc%Kv_slow are not in the group pass because it has larger vertical extent. + if (associated(visc%Kv_shear)) & + call pass_var(visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) + if (associated(visc%Kv_slow)) & + call pass_var(visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) + + call cpu_clock_end(id_clock_pass) + + call disable_averaging(CS%diag) + ! Frazil formation keeps temperature above the freezing point. + ! make_frazil is deliberately called at both the beginning and at + ! the end of the diabatic processes. + if (associated(tv%T) .AND. associated(tv%frazil)) then + call enable_averaging(0.5*dt, Time_end, CS%diag) + if (CS%frazil_tendency_diag) then + do k=1,nz ; do j=js,je ; do i=is,ie + temp_diag(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + + if (associated(fluxes%p_surf_full)) then + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) + else + call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) + endif + + if (CS%frazil_tendency_diag) then + call diagnose_frazil_tendency(tv, h, temp_diag, 0.5*dt, G, GV, CS) + if (CS%id_frazil_h > 0 ) call post_data(CS%id_frazil_h, h, CS%diag) + endif + + if (showCallTree) call callTree_waypoint("done with 2nd make_frazil (diabatic)") + if (CS%debugConservation) call MOM_state_stats('2nd make_frazil', u, v, h, tv%T, tv%S, G) + call disable_averaging(CS%diag) + + endif ! endif for frazil + + ! Diagnose the diapycnal diffusivities and other related quantities. + call enable_averaging(dt, Time_end, CS%diag) + + if (CS%id_Kd_interface > 0) call post_data(CS%id_Kd_interface, Kd_int, CS%diag) + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + + if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ea_t, CS%diag) + if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, eb_t, CS%diag) + if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ea_s, CS%diag) + if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, eb_s, CS%diag) + + if (CS%id_dudt_dia > 0) call post_data(CS%id_dudt_dia, ADp%du_dt_dia, CS%diag) + if (CS%id_dvdt_dia > 0) call post_data(CS%id_dvdt_dia, ADp%dv_dt_dia, CS%diag) + + if (CS%id_MLD_003 > 0 .or. CS%id_subMLN2 > 0 .or. CS%id_mlotstsq > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_003, h, tv, 0.03, G, GV, CS%diag, & + id_N2subML=CS%id_subMLN2, id_MLDsq=CS%id_mlotstsq) + endif + if (CS%id_MLD_0125 > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_0125, h, tv, 0.125, G, GV, CS%diag) + endif + if (CS%id_MLD_user > 0) then + call diagnoseMLDbyDensityDifference(CS%id_MLD_user, h, tv, CS%MLDdensityDifference, G, GV, CS%diag) + endif + + if (CS%id_Tdif > 0) call post_data(CS%id_Tdif, Tdif_flx, CS%diag) + if (CS%id_Tadv > 0) call post_data(CS%id_Tadv, Tadv_flx, CS%diag) + if (CS%id_Sdif > 0) call post_data(CS%id_Sdif, Sdif_flx, CS%diag) + if (CS%id_Sadv > 0) call post_data(CS%id_Sadv, Sadv_flx, CS%diag) + if (CS%use_int_tides) then + if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn(:,:,1),CS%diag) + do m=1,CS%nMode + if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m),cn(:,:,m),CS%diag) + enddo + endif + + call disable_averaging(CS%diag) + + num_z_diags = 0 + if (CS%id_Kd_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Kd_z ; z_ptrs(num_z_diags)%p => Kd_int + endif + if (CS%id_Tdif_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Tdif_z ; z_ptrs(num_z_diags)%p => Tdif_flx + endif + if (CS%id_Tadv_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Tadv_z ; z_ptrs(num_z_diags)%p => Tadv_flx + endif + if (CS%id_Sdif_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Sdif_z ; z_ptrs(num_z_diags)%p => Sdif_flx + endif + if (CS%id_Sadv_z > 0) then + num_z_diags = num_z_diags + 1 + z_ids(num_z_diags) = CS%id_Sadv_z ; z_ptrs(num_z_diags)%p => Sadv_flx + endif + + if (num_z_diags > 0) & + call calc_Zint_diags(h, z_ptrs, z_ids, num_z_diags, G, GV, CS%diag_to_Z_CSp) + + if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G) + if (showCallTree) call callTree_leave("diabatic()") + +end subroutine diabatic + +!> Imposes the diapycnal mass fluxes and the accompanying diapycnal advection of momentum and tracers +!! using the original MOM6 algorithms. +subroutine legacy_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + G, GV, CS, WAVES) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity (m/s) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity (m/s) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness (m for Bouss / kg/m2 for non-Bouss) + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + !! unused have NULL ptrs + real, dimension(:,:), pointer :: Hml !< active mixed layer depth + type(forcing), intent(inout) :: fluxes !< points to forcing fields + !! unused fields have NULL ptrs + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, BBL properies, and + type(accel_diag_ptrs), intent(inout) :: ADp !< related points to accelerations in momentum + !! equations, to enable the later derived + !! diagnostics, like energy budgets + type(cont_diag_ptrs), intent(inout) :: CDp !< points to terms in continuity equations + real, intent(in) :: dt !< time increment (seconds) + type(time_type), intent(in) :: Time_end !< Time at the end of the interval + type(diabatic_CS), pointer :: CS !< module control structure + type(Wave_parameters_CS), optional, pointer :: Waves !< Surface gravity waves real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & ea, & ! amount of fluid entrained from the layer above within @@ -384,8 +1274,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") - - ! Offer diagnostics of various state varables at the start of diabatic; + ! Offer diagnostics of various state varables 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) @@ -397,7 +1286,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call post_data(CS%id_e_predia, eta, CS%diag) endif - ! set equivalence between the same bits of memory for these arrays eaml => eatr ; ebml => ebtr @@ -424,16 +1312,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! Frazil formation keeps the temperature above the freezing point. ! make_frazil is deliberately called at both the beginning and at ! the end of the diabatic processes. - if (ASSOCIATED(tv%T) .AND. ASSOCIATED(tv%frazil)) then + if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step call enable_averaging(0.5*dt, Time_end - set_time(int(floor(0.5*dt+0.5))), CS%diag) - if(CS%frazil_tendency_diag) then + if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) enddo ; enddo ; enddo endif - if (ASSOCIATED(fluxes%p_surf_full)) then + if (associated(fluxes%p_surf_full)) then call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) else call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) @@ -512,7 +1400,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! from this limitation, in which case we can let salinity=0 and still ! have salt conserved with SIS2 ice. So for SIS2, we can run with ! BOUND_SALINITY=False in MOM.F90. - if (ASSOCIATED(tv%S) .and. ASSOCIATED(tv%salt_deficit)) & + if (associated(tv%S) .and. associated(tv%salt_deficit)) & call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) call cpu_clock_end(id_clock_mixedlayer) if (CS%debug) then @@ -612,9 +1500,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call calculateBuoyancyFlux2d(G, GV, fluxes, CS%optics, h, tv%T, tv%S, tv, & CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) ! The KPP scheme calculates boundary layer diffusivities and non-local transport. - ! MOM6 implementation of KPP matches the boundary layer to zero interior diffusivity, - ! since the matching to nonzero interior diffusivity can be problematic. - ! Changes: Kd_int. Sets: KPP_NLTheat, KPP_NLTscalar !$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,Kd_heat) !$OMP do @@ -639,9 +1524,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call KPP_compute_BLD(CS%KPP_CSp, G, GV, h, tv%T, tv%S, u, v, tv%eqn_of_state, & fluxes%ustar, CS%KPP_buoy_flux) - call KPP_calculate(CS%KPP_CSp, G, GV, h, tv%T, tv%S, u, v, tv%eqn_of_state, & - fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar) -!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,Kd_heat) + call KPP_calculate(CS%KPP_CSp, G, GV, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) +!$OMP parallel default(none) shared(is,ie,js,je,nz,Kd_salt,Kd_int,visc,CS,G,Kd_heat,Hml) if (associated(Hml)) then call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G) @@ -719,9 +1604,6 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! Differential diffusion done here. ! Changes: tv%T, tv%S - ! If using matching within the KPP scheme, then this step needs to provide - ! a diffusivity and happen before KPP. But generally in MOM, we do not match - ! KPP boundary layer to interior, so this diffusivity can be computed when convenient. if (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S) .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) @@ -732,17 +1614,15 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! increment heat and salt diffusivity. ! CS%useKPP==.true. already has extra_T and extra_S included - if(.not. CS%useKPP) then + if (.not. CS%useKPP) then do K=2,nz ; do j=js,je ; do i=is,ie Kd_heat(i,j,K) = Kd_heat(i,j,K) + visc%Kd_extra_T(i,j,K) Kd_salt(i,j,K) = Kd_salt(i,j,K) + visc%Kd_extra_S(i,j,K) enddo ; enddo ; enddo endif - endif - ! This block sets ea, eb from Kd or Kd_int. ! If using ALE algorithm, set ea=eb=Kd_int on interfaces for ! use in the tri-diagonal solver. @@ -787,7 +1667,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif ! Save fields before boundary forcing is applied for tendency diagnostics - if(CS%boundary_forcing_tendency_diag) then + if (CS%boundary_forcing_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie h_diag(i,j,k) = h(i,j,k) temp_diag(i,j,k) = tv%T(i,j,k) @@ -821,7 +1701,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call find_uv_at_h(u, v, h, u_h, v_h, G, GV) call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, & - CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux) + CS%energetic_PBL_CSp, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) ! If visc%MLD exists, copy the ePBL's MLD into it if (associated(visc%MLD)) then @@ -868,7 +1748,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! diagnose the tendencies due to boundary forcing ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme ! so all tendency diagnostics need to be posted on h_diag, and grids rebuilt afterwards - if(CS%boundary_forcing_tendency_diag) then + if (CS%boundary_forcing_tendency_diag) then call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, CS) if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h = h_diag) endif @@ -928,14 +1808,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (showCallTree) call callTree_waypoint("done with h=ea-eb (diabatic)") if (CS%debugConservation) call MOM_state_stats('h=ea-eb', u, v, h, tv%T, tv%S, G) - ! Here, T and S are updated according to ea and eb. ! If using the bulk mixed layer, T and S are also updated ! by surface fluxes (in fluxes%*). ! This is a very long block. if (CS%bulkmixedlayer) then - if (ASSOCIATED(tv%T)) then + if (associated(tv%T)) then call cpu_clock_begin(id_clock_tridiag) ! Temperature and salinity (as state variables) are treated ! differently from other tracers to insure massless layers that @@ -1018,7 +1897,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif ! massless_match_targets call cpu_clock_end(id_clock_tridiag) - endif ! endif for ASSOCIATED(T) + endif ! endif for associated(T) if (CS%debugConservation) call MOM_state_stats('BML tridiag', u, v, h, tv%T, tv%S, G) if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then @@ -1065,7 +1944,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! from this limitation, in which case we can let salinity=0 and still ! have salt conserved with SIS2 ice. So for SIS2, we can run with ! BOUND_SALINITY=False in MOM.F90. - if (ASSOCIATED(tv%S) .and. ASSOCIATED(tv%salt_deficit)) & + if (associated(tv%S) .and. associated(tv%salt_deficit)) & call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) call cpu_clock_end(id_clock_mixedlayer) @@ -1075,9 +1954,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G else ! following block for when NOT using BULKMIXEDLAYER - ! calculate change in temperature & salinity due to dia-coordinate surface diffusion - if (ASSOCIATED(tv%T)) then + if (associated(tv%T)) then if (CS%debug) then call hchksum(ea, "before triDiagTS ea ",G%HI,haloshift=0, scale=GV%H_to_m) @@ -1091,10 +1969,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! from this limitation, in which case we can let salinity=0 and still ! have salt conserved with SIS2 ice. So for SIS2, we can run with ! BOUND_SALINITY=False in MOM.F90. - if (ASSOCIATED(tv%S) .and. ASSOCIATED(tv%salt_deficit)) & + if (associated(tv%S) .and. associated(tv%salt_deficit)) & call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) - if(CS%diabatic_diff_tendency_diag) then + if (CS%diabatic_diff_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) saln_diag(i,j,k) = tv%S(i,j,k) @@ -1102,7 +1980,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif ! Changes T and S via the tridiagonal solver; no change to h - if(CS%tracer_tridiag) then + if (CS%tracer_tridiag) then call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) else @@ -1113,7 +1991,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! Note: hold here refers to the thicknesses from before the dual-entraintment when using ! the bulk mixed layer scheme. Otherwise in ALE-mode, layer thicknesses will have changed ! In either case, tendencies should be posted on hold - if(CS%diabatic_diff_tendency_diag) then + if (CS%diabatic_diff_tendency_diag) then call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, CS) if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h = hold) endif @@ -1121,13 +1999,11 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call cpu_clock_end(id_clock_tridiag) if (showCallTree) call callTree_waypoint("done with triDiagTS (diabatic)") - endif ! endif corresponding to if (ASSOCIATED(tv%T)) + endif ! endif corresponding to if (associated(tv%T)) if (CS%debugConservation) call MOM_state_stats('triDiagTS', u, v, h, tv%T, tv%S, G) - endif ! endif for the BULKMIXEDLAYER block - if (CS%debug) then call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, haloshift=0) call MOM_thermovar_chksum("after mixed layer ", tv, G) @@ -1282,11 +2158,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif ! (CS%mix_boundary_tracers) - - call cpu_clock_end(id_clock_tracers) - ! sponges if (CS%use_sponge) then call cpu_clock_begin(id_clock_sponge) @@ -1295,7 +2168,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G call apply_ALE_sponge(h, dt, G, CS%ALE_sponge_CSp, CS%Time) else ! Layer mode sponge - if (CS%bulkmixedlayer .and. ASSOCIATED(tv%eqn_of_state)) then + if (CS%bulkmixedlayer .and. associated(tv%eqn_of_state)) then do i=is,ie ; p_ref_cv(i) = tv%P_Ref ; enddo !$OMP parallel do default(shared) do j=js,je @@ -1314,9 +2187,8 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G endif endif ! CS%use_sponge - ! Save the diapycnal mass fluxes as a diagnostic field. - if (ASSOCIATED(CDp%diapyc_vel)) then + if (associated(CDp%diapyc_vel)) then !$OMP parallel do default(shared) do j=js,je do K=2,nz ; do i=is,ie @@ -1390,14 +2262,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) do j=js,je do I=Isq,Ieq - if (ASSOCIATED(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,1) = u(I,j,1) + if (associated(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,1) = u(I,j,1) hval = (hold(i,j,1) + hold(i+1,j,1)) + (ea(i,j,1) + ea(i+1,j,1)) + h_neglect b1(I) = 1.0 / (hval + (eb(i,j,1) + eb(i+1,j,1))) d1(I) = hval * b1(I) u(I,j,1) = b1(I) * (hval * u(I,j,1)) enddo do k=2,nz ; do I=Isq,Ieq - if (ASSOCIATED(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,k) = u(I,j,k) + if (associated(ADp%du_dt_dia)) ADp%du_dt_dia(I,j,k) = u(I,j,k) c1(I,k) = (eb(i,j,k-1)+eb(i+1,j,k-1)) * b1(I) eaval = ea(i,j,k) + ea(i+1,j,k) hval = hold(i,j,k) + hold(i+1,j,k) + h_neglect @@ -1407,10 +2279,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G enddo ; enddo do k=nz-1,1,-1 ; do I=Isq,Ieq u(I,j,k) = u(I,j,k) + c1(I,k+1)*u(I,j,k+1) - if (ASSOCIATED(ADp%du_dt_dia)) & + if (associated(ADp%du_dt_dia)) & ADp%du_dt_dia(I,j,k) = (u(I,j,k) - ADp%du_dt_dia(I,j,k)) * Idt enddo ; enddo - if (ASSOCIATED(ADp%du_dt_dia)) then + if (associated(ADp%du_dt_dia)) then do I=Isq,Ieq ADp%du_dt_dia(I,j,nz) = (u(I,j,nz)-ADp%du_dt_dia(I,j,nz)) * Idt enddo @@ -1422,14 +2294,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G !$OMP parallel do default(shared) private(hval,b1,d1,c1,eaval) do J=Jsq,Jeq do i=is,ie - if (ASSOCIATED(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,1) = v(i,J,1) + if (associated(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,1) = v(i,J,1) hval = (hold(i,j,1) + hold(i,j+1,1)) + (ea(i,j,1) + ea(i,j+1,1)) + h_neglect b1(i) = 1.0 / (hval + (eb(i,j,1) + eb(i,j+1,1))) d1(I) = hval * b1(I) v(i,J,1) = b1(i) * (hval * v(i,J,1)) enddo do k=2,nz ; do i=is,ie - if (ASSOCIATED(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,k) = v(i,J,k) + if (associated(ADp%dv_dt_dia)) ADp%dv_dt_dia(i,J,k) = v(i,J,k) c1(i,k) = (eb(i,j,k-1)+eb(i,j+1,k-1)) * b1(i) eaval = ea(i,j,k) + ea(i,j+1,k) hval = hold(i,j,k) + hold(i,j+1,k) + h_neglect @@ -1439,10 +2311,10 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie v(i,J,k) = v(i,J,k) + c1(i,k+1)*v(i,J,k+1) - if (ASSOCIATED(ADp%dv_dt_dia)) & + if (associated(ADp%dv_dt_dia)) & ADp%dv_dt_dia(i,J,k) = (v(i,J,k) - ADp%dv_dt_dia(i,J,k)) * Idt enddo ; enddo - if (ASSOCIATED(ADp%dv_dt_dia)) then + if (associated(ADp%dv_dt_dia)) then do i=is,ie ADp%dv_dt_dia(i,J,nz) = (v(i,J,nz)-ADp%dv_dt_dia(i,J,nz)) * Idt enddo @@ -1458,15 +2330,15 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G ! Frazil formation keeps temperature above the freezing point. ! make_frazil is deliberately called at both the beginning and at ! the end of the diabatic processes. - if (ASSOCIATED(tv%T) .AND. ASSOCIATED(tv%frazil)) then + if (associated(tv%T) .AND. associated(tv%frazil)) then call enable_averaging(0.5*dt, Time_end, CS%diag) - if(CS%frazil_tendency_diag) then + if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) enddo ; enddo ; enddo endif - if (ASSOCIATED(fluxes%p_surf_full)) then + if (associated(fluxes%p_surf_full)) then call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp, fluxes%p_surf_full) else call make_frazil(h, tv, G, GV, CS%diabatic_aux_CSp) @@ -1550,18 +2422,18 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, G, G if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G) if (showCallTree) call callTree_leave("diabatic()") -end subroutine diabatic +end subroutine legacy_diabatic !> Returns pointers or values of members within the diabatic_CS type. For extensibility, !! each returned argument is an optional argument subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & evap_CFL_limit, minimum_forcing_depth) - type(diabatic_CS), intent(in ) :: CS + type(diabatic_CS), intent(in ) :: CS ! All output arguments are optional - type(opacity_CS), pointer, optional, intent( out) :: opacity_CSp - type(optics_type), pointer, optional, intent( out) :: optics_CSp - real, optional, intent( out) :: evap_CFL_limit - real, optional, intent( out) :: minimum_forcing_depth + type(opacity_CS), optional, pointer :: opacity_CSp + type(optics_type), optional, pointer :: optics_CSp + real, optional, intent( out) :: evap_CFL_limit + real, optional, intent( out) :: minimum_forcing_depth ! Pointers to control structures if (present(opacity_CSp)) opacity_CSp => CS%opacity_CSp @@ -1575,13 +2447,14 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, & !> Routine called for adiabatic physics subroutine adiabatic(h, tv, fluxes, dt, G, GV, CS) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness (m for Bouss or kg/m2 for non-Bouss) - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields - type(forcing), intent(inout) :: fluxes !< boundary fluxes - real, intent(in) :: dt !< time step (seconds) - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(diabatic_CS), pointer :: CS !< module control structure + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h !< thickness (m for Bouss or kg/m2 for non-Bouss) + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields + type(forcing), intent(inout) :: fluxes !< boundary fluxes + real, intent(in) :: dt !< time step (seconds) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(diabatic_CS), pointer :: CS !< module control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: zeros ! An array of zeros. @@ -1621,19 +2494,19 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt enddo ; enddo ; enddo - if(CS%id_diabatic_diff_temp_tend > 0) then + if (CS%id_diabatic_diff_temp_tend > 0) then call post_data(CS%id_diabatic_diff_temp_tend, work_3d, CS%diag, alt_h = h) endif ! heat tendency - if(CS%id_diabatic_diff_heat_tend > 0 .or. CS%id_diabatic_diff_heat_tend_2d > 0) then + if (CS%id_diabatic_diff_heat_tend > 0 .or. CS%id_diabatic_diff_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * tv%C_p * work_3d(i,j,k) enddo ; enddo ; enddo - if(CS%id_diabatic_diff_heat_tend > 0) then + if (CS%id_diabatic_diff_heat_tend > 0) then call post_data(CS%id_diabatic_diff_heat_tend, work_3d, CS%diag, alt_h = h) endif - if(CS%id_diabatic_diff_heat_tend_2d > 0) then + if (CS%id_diabatic_diff_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1645,7 +2518,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, endif ! salinity tendency - if(CS%id_diabatic_diff_saln_tend > 0) then + if (CS%id_diabatic_diff_saln_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1653,14 +2526,14 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, endif ! salt tendency - if(CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then + if (CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * CS%ppt2mks * work_3d(i,j,k) enddo ; enddo ; enddo - if(CS%id_diabatic_diff_salt_tend > 0) then + if (CS%id_diabatic_diff_salt_tend > 0) then call post_data(CS%id_diabatic_diff_salt_tend, work_3d, CS%diag, alt_h = h) endif - if(CS%id_diabatic_diff_salt_tend_2d > 0) then + if (CS%id_diabatic_diff_salt_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1680,15 +2553,19 @@ end subroutine diagnose_diabatic_diff_tendency !! in which case we distribute the flux into k > 1 layers. subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, & dt, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< thickness after boundary flux application (m or kg/m2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: temp_old !< temperature prior to boundary flux application - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: saln_old !< salinity prior to boundary flux application (PPT) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< thickness prior to boundary flux application (m or kg/m2) - real, intent(in) :: dt !< time step (sec) - type(diabatic_CS), pointer :: CS !< module control structure + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(thermo_var_ptrs), intent(in) :: tv !< points to updated thermodynamic fields + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< thickness after boundary flux application (m or kg/m2) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: temp_old !< temperature prior to boundary flux application + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: saln_old !< salinity prior to boundary flux application (PPT) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< thickness prior to boundary flux application (m or kg/m2) + real, intent(in) :: dt !< time step (sec) + type(diabatic_CS), pointer :: CS !< module control structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: work_3d real, dimension(SZI_(G),SZJ_(G)) :: work_2d @@ -1701,7 +2578,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, work_2d(:,:) = 0.0 ! Thickness tendency - if(CS%id_boundary_forcing_h_tendency > 0) then + if (CS%id_boundary_forcing_h_tendency > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (h(i,j,k) - h_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1709,7 +2586,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! temperature tendency - if(CS%id_boundary_forcing_temp_tend > 0) then + if (CS%id_boundary_forcing_temp_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1717,14 +2594,14 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! heat tendency - if(CS%id_boundary_forcing_heat_tend > 0 .or. CS%id_boundary_forcing_heat_tend_2d > 0) then + if (CS%id_boundary_forcing_heat_tend > 0 .or. CS%id_boundary_forcing_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = GV%H_to_kg_m2 * tv%C_p * Idt * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * temp_old(i,j,k)) enddo ; enddo ; enddo - if(CS%id_boundary_forcing_heat_tend > 0) then + if (CS%id_boundary_forcing_heat_tend > 0) then call post_data(CS%id_boundary_forcing_heat_tend, work_3d, CS%diag, alt_h = h_old) endif - if(CS%id_boundary_forcing_heat_tend_2d > 0) then + if (CS%id_boundary_forcing_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1736,7 +2613,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! salinity tendency - if(CS%id_boundary_forcing_saln_tend > 0) then + if (CS%id_boundary_forcing_saln_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1744,14 +2621,14 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! salt tendency - if(CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then + if (CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = GV%H_to_kg_m2 * CS%ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) enddo ; enddo ; enddo - if(CS%id_boundary_forcing_salt_tend > 0) then + if (CS%id_boundary_forcing_salt_tend > 0) then call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h = h_old) endif - if(CS%id_boundary_forcing_salt_tend_2d > 0) then + if (CS%id_boundary_forcing_salt_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1802,7 +2679,7 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) ! As a consistency check, we must have ! FRAZIL_HEAT_TENDENCY_2d = HFSIFRAZIL - if(CS%id_frazil_heat_tend_2d > 0) then + if (CS%id_frazil_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1821,13 +2698,14 @@ end subroutine diagnose_frazil_tendency !! of the diabatic processes to be used. subroutine adiabatic_driver_init(Time, G, param_file, diag, CS, & tracer_flow_CSp, diag_to_Z_CSp) - type(time_type), intent(in) :: Time !< current model time - type(ocean_grid_type), intent(in) :: G !< model grid structure - type(param_file_type), intent(in) :: param_file !< the file to parse for parameter values - type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output - type(diabatic_CS), pointer :: CS !< module control structure - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< points to control structure of tracer flow control module - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< pointer to Z-diagnostics control structure + type(time_type), intent(in) :: Time !< current model time + type(ocean_grid_type), intent(in) :: G !< model grid structure + type(param_file_type), intent(in) :: param_file !< the file to parse for parameter values + type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output + type(diabatic_CS), pointer :: CS !< module control structure + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of the + !! tracer flow control module + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< pointer to Z-diagnostics control structure ! This "include" declares and sets the variable "version". #include "version_variable.h" @@ -1864,7 +2742,8 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, !! to enable diagnostics, like energy budgets type(cont_diag_ptrs), intent(inout) :: CDp !< pointers to terms in continuity equations type(diabatic_CS), pointer :: CS !< module control structure - type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of tracer flow control module + type(tracer_flow_control_CS), pointer :: tracer_flow_CSp !< pointer to control structure of the + !! tracer flow control module type(sponge_CS), pointer :: sponge_CSp !< pointer to the sponge module control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< pointer to the Z-diagnostics control structure @@ -1906,7 +2785,6 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, ! Set default, read and log parameters call log_version(param_file, mod, version, & "The following parameters are used for diabatic processes.") - call get_param(param_file, mod, "SPONGE", CS%use_sponge, & "If true, sponges may be applied anywhere in the domain. \n"//& "The exact location and properties of those sponges are \n"//& @@ -1926,8 +2804,18 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, call get_param(param_file, mod, "DOUBLE_DIFFUSION", differentialDiffusion, & "If true, apply parameterization of double-diffusion.", & default=.false. ) + + CS%use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) + + if (CS%use_CVMix_ddiff .and. differentialDiffusion) then + call MOM_error(FATAL, 'diabatic_driver_init: '// & + 'Multiple double-diffusion options selected (DOUBLE_DIFFUSION and'//& + 'USE_CVMIX_DDIFF), please disable all but one option to proceed.') + endif + CS%use_kappa_shear = kappa_shear_is_used(param_file) CS%use_CVMix_shear = CVMix_shear_is_used(param_file) + if (CS%bulkmixedlayer) then call get_param(param_file, mod, "ML_MIX_FIRST", CS%ML_mix_first, & "The fraction of the mixed layer mixing that is applied \n"//& @@ -1958,7 +2846,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_TEST", CS%int_tide_source_test, & "If true, apply an arbitrary generation site for internal tide testing", & default=.false.) - if(CS%int_tide_source_test)then + if (CS%int_tide_source_test)then call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & "X Location of generation site for internal tide", default=1.) call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & @@ -1971,7 +2859,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, ! GET UNIFORM MODE VELOCITY FOR TESTING (BDM) call get_param(param_file, mod, "UNIFORM_CG", CS%uniform_cg, & "If true, set cg = cg_test everywhere for test case", default=.false.) - if(CS%uniform_cg)then + if (CS%uniform_cg)then call get_param(param_file, mod, "CG_TEST", CS%cg_test, & "Uniform group velocity of internal tide for test case", default=1.) endif @@ -1994,9 +2882,11 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, default=.true.) call get_param(param_file, mod, "DEBUG", CS%debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mod, "DEBUG_CONSERVATION", CS%debugConservation, & - "If true, monitor conservation and extrema.", default=.false.) + "If true, monitor conservation and extrema.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mod, "DEBUG_ENERGY_REQ", CS%debug_energy_req, & "If true, debug the energy requirements.", default=.false., do_not_log=.true.) @@ -2039,16 +2929,24 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, if (GV%Boussinesq) then ; thickness_units = "m" else ; thickness_units = "kg m-2" ; endif + ! used by layer diabatic CS%id_ea = register_diag_field('ocean_model','ea',diag%axesTL,Time, & 'Layer entrainment from above per timestep','m') CS%id_eb = register_diag_field('ocean_model','eb',diag%axesTL,Time, & 'Layer entrainment from below per timestep', 'm') + + CS%id_ea_t = register_diag_field('ocean_model','ea_t',diag%axesTL,Time, & + 'Layer (heat) entrainment from above per timestep','m') + CS%id_eb_t = register_diag_field('ocean_model','eb_t',diag%axesTL,Time, & + 'Layer (heat) entrainment from below per timestep', 'm') + CS%id_ea_s = register_diag_field('ocean_model','ea_s',diag%axesTL,Time, & + 'Layer (salt) entrainment from above per timestep','m') + CS%id_eb_s = register_diag_field('ocean_model','eb_s',diag%axesTL,Time, & + 'Layer (salt) entrainment from below per timestep', 'm') CS%id_dudt_dia = register_diag_field('ocean_model','dudt_dia',diag%axesCuL,Time, & 'Zonal Acceleration from Diapycnal Mixing', 'm s-2') CS%id_dvdt_dia = register_diag_field('ocean_model','dvdt_dia',diag%axesCvL,Time, & 'Meridional Acceleration from Diapycnal Mixing', 'm s-2') - CS%id_wd = register_diag_field('ocean_model','wd',diag%axesTi,Time, & - 'Diapycnal Velocity', 'm s-1') if (CS%use_int_tides) then CS%id_cg1 = register_diag_field('ocean_model','cn1', diag%axesT1, & Time, 'First baroclinic mode (eigen) speed', 'm s-1') @@ -2118,7 +3016,6 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, if (CS%id_dudt_dia > 0) call safe_alloc_ptr(ADp%du_dt_dia,IsdB,IedB,jsd,jed,nz) if (CS%id_dvdt_dia > 0) call safe_alloc_ptr(ADp%dv_dt_dia,isd,ied,JsdB,JedB,nz) - if (CS%id_wd > 0) call safe_alloc_ptr(CDp%diapyc_vel,isd,ied,jsd,jed,nz+1) ! diagnostics for values prior to diabatic and prior to ALE CS%id_u_predia = register_diag_field('ocean_model', 'u_predia', diag%axesCuL, Time, & @@ -2169,6 +3066,12 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, allocate( CS%KPP_salt_flux(isd:ied,jsd:jed) ) ; CS%KPP_salt_flux(:,:) = 0. endif + if (CS%useKPP .and. differentialDiffusion) then + call MOM_error(FATAL, 'diabatic_driver_init: '// & + 'DOUBLE_DIFFUSION (old method) does not work with KPP. Please'//& + 'set DOUBLE_DIFFUSION=False and USE_CVMIX_DDIFF=True.') + endif + call get_param(param_file, mod, "SALT_REJECT_BELOW_ML", CS%salt_reject_below_ML, & "If true, place salt from brine rejection below the mixed layer,\n"// & "into the first non-vanished layer for which the column remains stable", & @@ -2180,7 +3083,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, endif - ! diagnostics for tendencies of temp and saln due to diabatic processes; + ! diagnostics for tendencies of temp and saln due to diabatic processes ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_diabatic_diff_h = register_diag_field('ocean_model', 'diabatic_diff_h', diag%axesTL, Time, & @@ -2200,59 +3103,59 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, CS%diabatic_diff_tendency_diag = .true. endif - CS%id_diabatic_diff_heat_tend = register_diag_field('ocean_model', & - 'diabatic_heat_tendency', diag%axesTL, Time, & - 'Diabatic diffusion heat tendency', & - 'W m-2',cmor_field_name='opottempdiff', & - cmor_standard_name= & - 'tendency_of_sea_water_potential_temperature_expressed_as_heat_content_due_to_parameterized_dianeutral_mixing',& - cmor_long_name = & - 'Tendency of sea water potential temperature expressed as heat content due to parameterized dianeutral mixing',& + CS%id_diabatic_diff_heat_tend = register_diag_field('ocean_model', & + 'diabatic_heat_tendency', diag%axesTL, Time, & + 'Diabatic diffusion heat tendency', & + 'W m-2',cmor_field_name='opottempdiff', & + cmor_standard_name='tendency_of_sea_water_potential_temperature_expressed_as_heat_content_'// & + 'due_to_parameterized_dianeutral_mixing', & + cmor_long_name='Tendency of sea water potential temperature expressed as heat content '// & + 'due to parameterized dianeutral mixing',& v_extensive=.true.) if (CS%id_diabatic_diff_heat_tend > 0) then CS%diabatic_diff_tendency_diag = .true. endif - CS%id_diabatic_diff_salt_tend = register_diag_field('ocean_model', & - 'diabatic_salt_tendency', diag%axesTL, Time, & - 'Diabatic diffusion of salt tendency', & - 'kg m-2 s-1',cmor_field_name='osaltdiff', & - cmor_standard_name= & - 'tendency_of_sea_water_salinity_expressed_as_salt_content_due_to_parameterized_dianeutral_mixing', & - cmor_long_name = & - 'Tendency of sea water salinity expressed as salt content due to parameterized dianeutral mixing', & + CS%id_diabatic_diff_salt_tend = register_diag_field('ocean_model', & + 'diabatic_salt_tendency', diag%axesTL, Time, & + 'Diabatic diffusion of salt tendency', & + 'kg m-2 s-1',cmor_field_name='osaltdiff', & + cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & + 'due_to_parameterized_dianeutral_mixing', & + cmor_long_name='Tendency of sea water salinity expressed as salt content '// & + 'due to parameterized dianeutral mixing', & v_extensive=.true.) if (CS%id_diabatic_diff_salt_tend > 0) then CS%diabatic_diff_tendency_diag = .true. endif ! This diagnostic should equal to roundoff if all is working well. - CS%id_diabatic_diff_heat_tend_2d = register_diag_field('ocean_model', & - 'diabatic_heat_tendency_2d', diag%axesT1, Time, & - 'Depth integrated diabatic diffusion heat tendency', & - 'W m-2',cmor_field_name='opottempdiff_2d', & - cmor_standard_name= & - 'tendency_of_sea_water_potential_temperature_expressed_as_heat_content_due_to_parameterized_dianeutral_mixing_depth_integrated',& - cmor_long_name = & - 'Tendency of sea water potential temperature expressed as heat content due to parameterized dianeutral mixing depth integrated') + CS%id_diabatic_diff_heat_tend_2d = register_diag_field('ocean_model', & + 'diabatic_heat_tendency_2d', diag%axesT1, Time, & + 'Depth integrated diabatic diffusion heat tendency', & + 'W m-2',cmor_field_name='opottempdiff_2d', & + cmor_standard_name='tendency_of_sea_water_potential_temperature_expressed_as_heat_content_'//& + 'due_to_parameterized_dianeutral_mixing_depth_integrated', & + cmor_long_name='Tendency of sea water potential temperature expressed as heat content '//& + 'due to parameterized dianeutral mixing depth integrated') if (CS%id_diabatic_diff_heat_tend_2d > 0) then CS%diabatic_diff_tendency_diag = .true. endif ! This diagnostic should equal to roundoff if all is working well. - CS%id_diabatic_diff_salt_tend_2d = register_diag_field('ocean_model', & - 'diabatic_salt_tendency_2d', diag%axesT1, Time, & - 'Depth integrated diabatic diffusion salt tendency', & - 'kg m-2 s-1',cmor_field_name='osaltdiff_2d', & - cmor_standard_name= & - 'tendency_of_sea_water_salinity_expressed_as_salt_content_due_to_parameterized_dianeutral_mixing_depth_integrated',& - cmor_long_name = & - 'Tendency of sea water salinity expressed as salt content due to parameterized dianeutral mixing depth integrated') + CS%id_diabatic_diff_salt_tend_2d = register_diag_field('ocean_model', & + 'diabatic_salt_tendency_2d', diag%axesT1, Time, & + 'Depth integrated diabatic diffusion salt tendency', & + 'kg m-2 s-1',cmor_field_name='osaltdiff_2d', & + cmor_standard_name='tendency_of_sea_water_salinity_expressed_as_salt_content_'// & + 'due_to_parameterized_dianeutral_mixing_depth_integrated', & + cmor_long_name='Tendency of sea water salinity expressed as salt content '// & + 'due to parameterized dianeutral mixing depth integrated') if (CS%id_diabatic_diff_salt_tend_2d > 0) then CS%diabatic_diff_tendency_diag = .true. endif - ! diagnostics for tendencies of thickness temp and saln due to boundary forcing; + ! diagnostics for tendencies of thickness temp and saln due to boundary forcing ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_boundary_forcing_h = register_diag_field('ocean_model', 'boundary_forcing_h', diag%axesTL, Time, & @@ -2366,7 +3269,8 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, endif ! initialize module for setting diffusivities - call set_diffusivity_init(Time, G, GV, param_file, diag, CS%set_diff_CSp, diag_to_Z_CSp, CS%int_tide_CSp, CS%tidal_mixing_CSp) + call set_diffusivity_init(Time, G, GV, param_file, diag, CS%set_diff_CSp, diag_to_Z_CSp, & + CS%int_tide_CSp, CS%tidal_mixing_CSp) ! set up the clocks for this module @@ -2410,7 +3314,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, endif endif CS%nsw = 0 - if (ASSOCIATED(CS%optics)) CS%nsw = CS%optics%nbands + if (associated(CS%optics)) CS%nsw = CS%optics%nbands ! Initialize the diagnostic grid storage call diag_grid_storage_init(CS%diag_grids_prev, G, diag) @@ -2460,8 +3364,7 @@ subroutine diabatic_driver_end(CS) !call diag_grid_storage_end(CS%diag_grids_prev) - if (associated(CS)) deallocate(CS) - + deallocate(CS) end subroutine diabatic_driver_end diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 7054a90ca4..2678b18e1a 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -282,8 +282,10 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do_print = .false. ; if (present(may_print) .and. present(CS)) do_print = may_print - dPEa_dKd(:) = 0.0 ; dPEa_dKd_est(:) = 0.0 ; dPEa_dKd_err(:) = 0.0 ; dPEa_dKd_err_norm(:) = 0.0 ; dPEa_dKd_trunc(:) = 0.0 - dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 ; dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 + dPEa_dKd(:) = 0.0 ; dPEa_dKd_est(:) = 0.0 ; dPEa_dKd_err(:) = 0.0 + dPEa_dKd_err_norm(:) = 0.0 ; dPEa_dKd_trunc(:) = 0.0 + dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 + dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 htot = 0.0 ; pres(1) = 0.0 ; Z_int(1) = 0.0 do k=1,nz @@ -1089,7 +1091,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ColHt_chg = ColHt_core * y1 if (ColHt_chg < 0.0) PE_chg = PE_chg - pres * ColHt_chg if (present(ColHt_cor)) ColHt_cor = -pres * min(ColHt_chg, 0.0) - else if (present(ColHt_cor)) then + elseif (present(ColHt_cor)) then y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) ColHt_cor = -pres * min(ColHt_core * y1, 0.0) endif diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 25b018e734..a58773d066 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -57,6 +57,8 @@ module MOM_energetic_PBL use MOM_grid, only : ocean_grid_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_EOS, only : calculate_density, calculate_density_derivs implicit none ; private @@ -137,6 +139,7 @@ module MOM_energetic_PBL real :: MSTAR_XINT_UP ! Similar but for transition to asymptotic cap. real :: MSTAR_AT_XINT ! Intercept value of MSTAR at value where function ! changes to linear transition. + integer :: LT_ENHANCE_FORM ! Integer for Enhancement functional form (various options) real :: LT_ENHANCE_COEF ! Coefficient in fit for Langmuir Enhancment real :: LT_ENHANCE_EXP ! Exponent in fit for Langmuir Enhancement real :: MSTAR_N = -2. ! Exponent in decay at negative and positive limits of MLD_over_STAB @@ -150,17 +153,16 @@ module MOM_energetic_PBL real :: LaC_EKoOB_stab ! and OB is Obukhov, the "o" in the name is for division. real :: LaC_MLDoOB_un ! Stab/un are for stable (pos) and unstable (neg) Obukhov depths real :: LaC_EKoOB_un ! ... - real :: LaDepthRatio=0.04 ! The ratio of OBL depth to average Stokes drift over real :: Max_Enhance_M = 5. ! The maximum allowed LT enhancement to the mixing. real :: CNV_MST_FAC ! Factor to reduce mstar when statically unstable. type(time_type), pointer :: Time ! A pointer to the ocean model's clock. - integer :: LT_Enhance_Form = 0 ! Option for Langmuir enhancement form + integer :: MSTAR_MODE = 0 ! An integer to determine which formula is used to ! set mstar integer :: CONST_MSTAR=0,MLD_o_OBUKHOV=1,EKMAN_o_OBUKHOV=2 logical :: MSTAR_FLATCAP=.true. !Set false to use asymptotic mstar cap. logical :: TKE_diagnostics = .false. - logical :: Use_LA_windsea = .false. + logical :: Use_LT = .false. ! Flag for using LT in Energy calculation logical :: orig_PE_calc = .true. logical :: Use_MLD_iteration=.false. ! False to use old ePBL method. logical :: Orig_MLD_iteration=.false. ! False to use old MLD value @@ -168,6 +170,7 @@ module MOM_energetic_PBL ! ocean depth for the iteration. logical :: Mixing_Diagnostics = .false. ! Will be true when outputing mixing ! length and velocity scale + logical :: MSTAR_Diagnostics=.false. type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the ! timing of diagnostic output. @@ -187,6 +190,7 @@ module MOM_energetic_PBL ML_depth2, & ! The mixed layer depth in m. (guess for iteration step) Enhance_M, & ! The enhancement to the turbulent velocity scale (non-dim) MSTAR_MIX, & ! Mstar used in EPBL + MSTAR_LT, & ! Mstar for Langmuir turbulence MLD_EKMAN, & ! MLD over Ekman length MLD_OBUKHOV, & ! MLD over Obukhov length EKMAN_OBUKHOV, & ! Ekman over Obukhov length @@ -202,8 +206,8 @@ module MOM_energetic_PBL integer :: id_Hsfc_used = -1 integer :: id_Mixing_Length = -1, id_Velocity_Scale = -1 integer :: id_OSBL = -1, id_LT_Enhancement = -1, id_MSTAR_mix = -1 - integer :: id_mld_ekman, id_mld_obukhov, id_ekman_obukhov - integer :: id_LA, id_LA_mod + integer :: id_mld_ekman = -1, id_mld_obukhov = -1, id_ekman_obukhov = -1 + integer :: id_LA_mod = -1, id_LA = -1, id_MSTAR_LT = -1 end type energetic_PBL_CS integer :: num_msg = 0, max_msg = 2 @@ -216,7 +220,7 @@ module MOM_energetic_PBL !! is no stability limit on the time step. subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & dSV_dT, dSV_dS, TKE_forced, Buoy_Flux, dt_diag, last_call, & - dT_expected, dS_expected ) + dT_expected, dS_expected, waves ) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -262,7 +266,15 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & !! diagnostics will be written. The default !! is .true. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: dT_expected, dS_expected + optional, intent(out) :: dT_expected !< The values of temperature change that + !! should be expected when the returned + !! diffusivities are applied, in K. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out) :: dS_expected !< The values of salinity change that + !! should be expected when the returned + !! diffusivities are applied, in psu. + type(wave_parameters_CS), & + optional, pointer :: Waves !< Wave CS ! This subroutine determines the diffusivities from the integrated energetics ! mixed layer model. It assumes that heating, cooling and freshwater fluxes @@ -556,16 +568,16 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & if (.not. associated(CS)) call MOM_error(FATAL, "energetic_PBL: "//& "Module must be initialized before it is used.") - if (.not. ASSOCIATED(tv%eqn_of_state)) call MOM_error(FATAL, & + if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & "energetic_PBL: Temperature, salinity and an equation of state "//& "must now be used.") - if (.NOT. ASSOCIATED(fluxes%ustar)) call MOM_error(FATAL, & + if (.NOT. associated(fluxes%ustar)) call MOM_error(FATAL, & "energetic_PBL: No surface TKE fluxes (ustar) defined in mixedlayer!") if (present(dT_expected) .or. present(dS_expected)) debug = .true. h_neglect = GV%H_subroundoff - if(.not.CS%Use_MLD_Iteration) MAX_OBL_IT=1 + if (.not.CS%Use_MLD_Iteration) MAX_OBL_IT=1 C1_3 = 1.0 / 3.0 dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag IdtdR0 = 1.0 / (dt__diag * GV%Rho0) @@ -760,6 +772,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & ! Iterate up to MAX_OBL_IT times to determine a converged EPBL depth. OBL_CONVERGED = .false. + ! Initialize ENHANCE_M to 1 and mstar_lt to 0 ENHANCE_M=1.e0 MSTAR_LT = 0.0 @@ -771,7 +784,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & sfc_connected(i) = .true. - if (CS%Mstar_Mode.gt.0) then + if (CS%Mstar_Mode > 0) then ! Note the value of mech_TKE(i) now must be iterated over, so it is moved here ! First solve for the TKE to PE length scale if (CS%MSTAR_MODE == CS%MLD_o_OBUKHOV) then @@ -826,9 +839,9 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & MSTAR_Conv_Adj = 1. - CS%CNV_MST_FAC * (-BF_Unstable+1.e-10) / & ( (-Bf_Unstable+1.e-10)+ & 2. *MSTAR_MIX *U_STAR**3 / MLD_GUESS ) - if (CS%Use_LA_windsea) then - ! 1. Get LA - call get_LA_windsea( u_star_mean, MLD_guess*CS%LaDepthRatio, GV, LA) + if (CS%USE_LT) then + call get_Langmuir_Number( LA, G, GV, abs(MLD_guess), u_star_mean, I, J, & + H=H(i,:), U_H=U(i,:), V_H=V(i,:), WAVES=WAVES) ! 2. Get parameters for modified LA MLD_o_Ekman = abs(MLD_guess*iL_Ekman) MLD_o_Obukhov_stab = abs(max(0.,MLD_guess*iL_Obukhov)) @@ -844,7 +857,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & CS%LaC_MLDoOB_stab * MLD_o_Obukhov_stab + & CS%LaC_MLDoOB_un * MLD_o_Obukhov_un ) if (CS%LT_Enhance_Form==1) then - !Original w'/ust scaling w/ Van Roekel's scaling + !Original w'/ust scaling w/ Van Roekel et al. 2012 scaling + ! NOTE we know now that this is not the right way to scale M. ENHANCE_M = (1+(1.4*LA)**(-2)+(5.4*LA)**(-4))**(1.5) elseif (CS%LT_Enhance_Form==2) then ! Enhancement is multiplied (added mst_lt set to 0) @@ -968,6 +982,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & nstar_FC = CS%nstar * conv_PErel(i) / (conv_PErel(i) + 0.2 * & sqrt(0.5 * dt * GV%Rho0 * (absf(i)*(htot(i)*GV%H_to_m))**3 * conv_PErel(i))) endif + if (debug) nstar_k(K) = nstar_FC tot_TKE = mech_TKE(i) + nstar_FC * conv_PErel(i) @@ -1137,7 +1152,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & MKE_src = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) - if (pe_chg_g0 .gt. 0.0) then + if (pe_chg_g0 > 0.0) then !Negative buoyancy (increases PE) N2_dissipation = 1.+CS%N2_DISSIPATION_SCALE_NEG else @@ -1237,7 +1252,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & ! There is not enough energy to support the mixing, so reduce the ! diffusivity to what can be supported. Kddt_h_max = Kddt_h_g0 ; Kddt_h_min = 0.0 - TKE_left_max = tot_TKE + (MKE_src - N2_DISSIPATION*PE_chg_g0) ; + TKE_left_max = tot_TKE + (MKE_src - N2_DISSIPATION*PE_chg_g0) TKE_left_min = tot_TKE ! As a starting guess, take the minimum of a false position estimate @@ -1502,6 +1517,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & endif if (allocated(CS%Enhance_M)) CS%Enhance_M(i,j) = Enhance_M if (allocated(CS%mstar_mix)) CS%mstar_mix(i,j) = MSTAR_MIX + if (allocated(CS%mstar_lt)) CS%mstar_lt(i,j) = MSTAR_LT if (allocated(CS%MLD_Obukhov)) CS%MLD_Obukhov(i,j) = (MLD_guess*iL_Obukhov) if (allocated(CS%MLD_Ekman)) CS%MLD_Ekman(i,j) = (MLD_guess*iL_Ekman) if (allocated(CS%Ekman_Obukhov)) CS%Ekman_Obukhov(i,j) = (iL_Obukhov/(iL_Ekman+1.e-10)) @@ -1572,7 +1588,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & 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) endif end subroutine energetic_PBL @@ -1693,7 +1710,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ColHt_chg = ColHt_core * y1 if (ColHt_chg < 0.0) PE_chg = PE_chg - pres * ColHt_chg if (present(ColHt_cor)) ColHt_cor = -pres * min(ColHt_chg, 0.0) - else if (present(ColHt_cor)) then + elseif (present(ColHt_cor)) then y1 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) ColHt_cor = -pres * min(ColHt_core * y1, 0.0) endif @@ -1908,7 +1925,7 @@ subroutine ust_2_u10_coare3p5(USTair,U10,GV) z0sm = 0.11 * nu / USTair; !Compute z0smooth from ustar guess u10 = USTair/sqrt(0.001); !Guess for u10 - u10a = 1000; + u10a = 1000 CT=0 do while (abs(u10a/u10-1.)>0.001) @@ -1939,7 +1956,7 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) ! wind (m/s), friction velocity (m/s) and the boundary layer depth (m). ! Update (Jan/25): ! Converted from function to subroutine, now returns Langmuir number. -! Computs 10m wind internally, so only ustar and hbl need passed to +! Computes 10m wind internally, so only ustar and hbl need passed to ! subroutine. ! ! Qing Li, 160606 @@ -1971,7 +1988,7 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) real :: z0, z0i, r1, r2, r3, r4, tmp, us_sl, lasl_sqr_i real :: pi, u10 pi = 4.0*atan(1.0) - if (ustar .gt. 0.0) then + if (ustar > 0.0) then ! Computing u10 based on u_star and COARE 3.5 relationships call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/1.225),U10,GV) ! surface Stokes drift @@ -2048,6 +2065,7 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) real :: omega_frac_dflt integer :: isd, ied, jsd, jed logical :: use_temperature, use_omega + logical :: use_la_windsea isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed if (associated(CS)) then @@ -2185,7 +2203,7 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) "at the edge of the boundary layer as a fraction of the \n"//& "boundary layer thickness. The default is 0.1.", & units="nondim", default=0.1) - if ( CS%USE_MLD_ITERATION .and. abs(CS%transLay_scale-0.5).ge.0.5) then + if ( CS%USE_MLD_ITERATION .and. abs(CS%transLay_scale-0.5) >= 0.5) then call MOM_error(FATAL, "If flag USE_MLD_ITERATION is true, then "// & "EPBL_TRANSITION should be greater than 0 and less than 1.") endif @@ -2199,50 +2217,53 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) "in the boundary layer, applied when local stratification \n"// & "is negative. The default is 0, but should probably be ~1.", & units="nondim", default=0.0) - call get_param(param_file, mdl, "USE_LA_LI2016", CS%USE_LA_Windsea, & - "A logical to use the Li et al. 2016 (submitted) formula to \n"//& - " determine the Langmuir number.", & - units="nondim", default=.false.) - call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LaDepthRatio, & - "The depth (normalized by BLD) to average Stokes drift over in \n"//& - " Lanmguir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim",default=0.04) - call get_param(param_file, mdl, "LT_ENHANCE", CS%LT_ENHANCE_FORM, & - "Integer for Langmuir number mode. \n"// & - " *Requires USE_LA_LI2016 to be set to True. \n"// & - "Options: 0 - No Langmuir \n"// & - " 1 - Van Roekel et al. 2014/Li et al., 2016 \n"//& - " 2 - Multiplied w/ adjusted La. \n"// & - " 3 - Added w/ adjusted La.", & - units="nondim", default=0) - call get_param(param_file, mdl, "LT_ENHANCE_COEF", CS%LT_ENHANCE_COEF, & - "Coefficient for Langmuir enhancement if LT_ENHANCE > 1",& - units="nondim", default=0.447) - call get_param(param_file, mdl, "LT_ENHANCE_EXP", CS%LT_ENHANCE_EXP, & - "Exponent for Langmuir enhancement if LT_ENHANCE > 1", & - units="nondim", default=-1.33) - call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLDoEK, & - "Coefficient for modification of Langmuir number due to\n"//& - " MLD approaching Ekman depth if LT_ENHANCE=2.", & - units="nondim", default=-0.87) - call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLDoOB_stab, & - "Coefficient for modification of Langmuir number due to\n"//& - " MLD approaching stable Obukhov depth if LT_ENHANCE=2.", & - units="nondim", default=0.0) - call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLDoOB_un, & - "Coefficient for modification of Langmuir number due to\n"//& - " MLD approaching unstable Obukhov depth if LT_ENHANCE=2.", & - units="nondim", default=0.0) - call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_EKoOB_stab, & - "Coefficient for modification of Langmuir number due to\n"//& - " ratio of Ekman to stable Obukhov depth if LT_ENHANCE=2.", & - units="nondim", default=0.95) - call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_EKoOB_un, & - "Coefficient for modification of Langmuir number due to\n"// & - " ratio of Ekman to unstable Obukhov depth if LT_ENHANCE=2.",& - units="nondim", default=0.95) - if (CS%LT_ENHANCE_FORM>0 .and. (.not.CS%USE_LA_Windsea)) then - call MOM_error(FATAL, "If flag USE_LA_LI2016 is false, LT_ENHANCE must be 0.") + call get_param(param_file, mdl, "USE_LA_LI2016", USE_LA_Windsea, & + "A logical to use the Li et al. 2016 (submitted) formula to \n"//& + " determine the Langmuir number.", & + units="nondim", default=.false.) + ! Note this can be activated in other ways, but this preserves the old method. + if (use_la_windsea) then + CS%USE_LT = .true. + else + call get_param(param_file, mdl, "EPBL_LT", CS%USE_LT, & + "A logical to use a LT parameterization.", & + units="nondim", default=.false.) + endif + if (CS%USE_LT) then + call get_param(param_file, mdl, "LT_ENHANCE", CS%LT_ENHANCE_FORM, & + "Integer for Langmuir number mode. \n"// & + " *Requires USE_LA_LI2016 to be set to True. \n"// & + "Options: 0 - No Langmuir \n"// & + " 1 - Van Roekel et al. 2014/Li et al., 2016 \n"// & + " 2 - Multiplied w/ adjusted La. \n"// & + " 3 - Added w/ adjusted La.", & + units="nondim", default=0) + call get_param(param_file, mdl, "LT_ENHANCE_COEF", CS%LT_ENHANCE_COEF, & + "Coefficient for Langmuir enhancement if LT_ENHANCE > 1", & + units="nondim", default=0.447) + call get_param(param_file, mdl, "LT_ENHANCE_EXP", CS%LT_ENHANCE_EXP, & + "Exponent for Langmuir enhancement if LT_ENHANCE > 1", & + units="nondim", default=-1.33) + call get_param(param_file, mdl, "LT_MOD_LAC1", CS%LaC_MLDoEK, & + "Coefficient for modification of Langmuir number due to\n"//& + " MLD approaching Ekman depth if LT_ENHANCE=2.", & + units="nondim", default=-0.87) + call get_param(param_file, mdl, "LT_MOD_LAC2", CS%LaC_MLDoOB_stab, & + "Coefficient for modification of Langmuir number due to\n"// & + " MLD approaching stable Obukhov depth if LT_ENHANCE=2.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "LT_MOD_LAC3", CS%LaC_MLDoOB_un, & + "Coefficient for modification of Langmuir number due to\n"//& + " MLD approaching unstable Obukhov depth if LT_ENHANCE=2.", & + units="nondim", default=0.0) + call get_param(param_file, mdl, "LT_MOD_LAC4", CS%Lac_EKoOB_stab, & + "Coefficient for modification of Langmuir number due to\n"// & + " ratio of Ekman to stable Obukhov depth if LT_ENHANCE=2.", & + units="nondim", default=0.95) + call get_param(param_file, mdl, "LT_MOD_LAC5", CS%Lac_EKoOB_un, & + "Coefficient for modification of Langmuir number due to\n"// & + " ratio of Ekman to unstable Obukhov depth if LT_ENHANCE=2.",& + units="nondim", default=0.95) endif ! This gives a minimum decay scale that is typically much less than Angstrom. CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_z + GV%H_to_m*GV%H_subroundoff) @@ -2292,7 +2313,8 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) Time, 'Langmuir number.', 'nondim') CS%id_LA_mod = register_diag_field('ocean_model', 'LA_MOD', diag%axesT1, & Time, 'Modified Langmuir number.', 'nondim') - + CS%id_MSTAR_LT = register_diag_field('ocean_model', 'MSTAR_LT', diag%axesT1, & + Time, 'MSTAR applied for LT effect.', 'nondim') call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & "If true, temperature and salinity are used as state \n"//& @@ -2321,7 +2343,7 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) call safe_alloc_alloc(CS%ML_depth, isd, ied, jsd, jed) call safe_alloc_alloc(CS%ML_depth2, isd, ied, jsd, jed) if (max(CS%id_LT_Enhancement, CS%id_mstar_mix,CS%id_mld_ekman, & - CS%id_ekman_obukhov, CS%id_mld_obukhov, CS%id_LA, CS%id_LA_mod)>0) then + CS%id_ekman_obukhov, CS%id_mld_obukhov, CS%id_LA, CS%id_LA_mod, CS%id_MSTAR_LT ) >0) then call safe_alloc_alloc(CS%Mstar_mix, isd, ied, jsd, jed) call safe_alloc_alloc(CS%Enhance_M, isd, ied, jsd, jed) call safe_alloc_alloc(CS%MLD_EKMAN, isd, ied, jsd, jed) @@ -2329,6 +2351,7 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) call safe_alloc_alloc(CS%EKMAN_OBUKHOV, isd, ied, jsd, jed) call safe_alloc_alloc(CS%LA, isd, ied, jsd, jed) call safe_alloc_alloc(CS%LA_MOD, isd, ied, jsd, jed) + call safe_alloc_alloc(CS%MSTAR_LT, isd, ied, jsd, jed) endif !Fitting coefficients to asymptote twoard 0 as MLD -> Ekman depth @@ -2356,8 +2379,9 @@ subroutine energetic_PBL_end(CS) if (allocated(CS%MLD_OBUKHOV)) deallocate(CS%MLD_OBUKHOV) if (allocated(CS%EKMAN_OBUKHOV)) deallocate(CS%EKMAN_OBUKHOV) if (allocated(CS%LA)) deallocate(CS%LA) - if (allocated(CS%LA_mod)) deallocate(CS%LA_mod) + if (allocated(CS%LA_MOD)) deallocate(CS%LA_MOD) if (allocated(CS%MSTAR_MIX)) deallocate(CS%MSTAR_MIX) + if (allocated(CS%MSTAR_LT)) deallocate(CS%MSTAR_LT) if (allocated(CS%diag_TKE_wind)) deallocate(CS%diag_TKE_wind) if (allocated(CS%diag_TKE_MKE)) deallocate(CS%diag_TKE_MKE) if (allocated(CS%diag_TKE_conv)) deallocate(CS%diag_TKE_conv) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 3da47e51e6..5f3f982dd1 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -284,9 +284,9 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & if (.not.(present(Kd_Lay) .or. present(Kd_int))) call MOM_error(FATAL, & "MOM_entrain_diffusive: Either Kd_Lay or Kd_int must be present in call.") - if ((.not.CS%bulkmixedlayer .and. .not.ASSOCIATED(fluxes%buoy)) .and. & - (ASSOCIATED(fluxes%lprec) .or. ASSOCIATED(fluxes%evap) .or. & - ASSOCIATED(fluxes%sens) .or. ASSOCIATED(fluxes%sw))) then + if ((.not.CS%bulkmixedlayer .and. .not.associated(fluxes%buoy)) .and. & + (associated(fluxes%lprec) .or. associated(fluxes%evap) .or. & + associated(fluxes%sens) .or. associated(fluxes%sw))) then if (is_root_pe()) call MOM_error(NOTE, "Calculate_Entrainment: & &The code to handle evaporation and precipitation without & &a bulk mixed layer has not been implemented.") @@ -454,7 +454,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & maxF(i,1) = 0.0 htot(i) = h(i,j,1) - Angstrom enddo - if (ASSOCIATED(fluxes%buoy)) then ; do i=is,ie + if (associated(fluxes%buoy)) then ; do i=is,ie maxF(i,1) = (dt*fluxes%buoy(i,j)) / GV%g_prime(2) enddo ; endif endif @@ -736,7 +736,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & F(i,k) = MIN(F(i,k), ds_dsp1(i,k)*( ((F(i,k-1) + & dsp1_ds(i,k-1)*F(i,k-1)) - F(i,k-2)) + (h(i,j,k-1) - Angstrom))) F(i,k) = MAX(F(i,k),MIN(minF(i,k),0.0)) - else if (k == kb(i)+1) then + elseif (k == kb(i)+1) then F(i,k) = MIN(F(i,k), ds_dsp1(i,k)*( ((F(i,k-1) + eakb(i)) - & eb_kmb(i)) + (h(i,j,k-1) - Angstrom))) F(i,k) = MAX(F(i,k),MIN(minF(i,k),0.0)) @@ -791,7 +791,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & ea(i,j,k) = ea(i,j,k) - dsp1_ds(i,k)*F_cor eb(i,j,k) = eb(i,j,k) + F_cor - else if ((k==kb(i)) .and. (F(i,k) > 0.0)) then + elseif ((k==kb(i)) .and. (F(i,k) > 0.0)) then ! Rho_cor is the density anomaly that needs to be corrected, ! taking into account that the true potential density of the ! deepest buffer layer is not exactly what is returned as dS_kb. @@ -817,7 +817,7 @@ subroutine entrainment_diffusive(u, v, h, tv, fluxes, dt, G, GV, CS, ea, eb, & ea(i,j,k) = ea(i,j,k) + ea_cor eb(i,j,k) = eb(i,j,k) - (dS_kb(i) * I_dSkbp1(i)) * ea_cor - else if (k < kb(i)) then + elseif (k < kb(i)) then ! Repetative, unless ea(kb) has been corrected. ea(i,j,k) = ea(i,j,k+1) endif @@ -1007,7 +1007,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb, ! elsewhere, so F should always be nonnegative. ea(i,j,k) = dsp1_ds(i,k)*F(i,k) eb(i,j,k) = F(i,k) - else if (k == kb(i)) then + elseif (k == kb(i)) then ea(i,j,k) = eakb(i) eb(i,j,k) = F(i,k) elseif (k == kb(i)-1) then @@ -1513,7 +1513,10 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & end subroutine determine_dSkb - +!> Given an entrainment from below for layer kb, determine a consistent +!! entrainment from above, such that dSkb * ea_kb = dSkbp1 * F_kb. The input +!! value of ea_kb is both the maximum value that can be obtained and the first +!! guess of the iterations. Ideally ea_kb should be an under-estimate subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & G, GV, CS, ea_kb, tol_in) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -1525,10 +1528,6 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & real, dimension(SZI_(G)), intent(inout) :: ea_kb real, optional, intent(in) :: tol_in - ! Given an entrainment from below for layer kb, determine a consistent - ! entrainment from above, such that dSkb * ea_kb = dSkbp1 * F_kb. The input - ! value of ea_kb is both the maximum value that can be obtained and the first - ! guess of the iterations. Also, make sure that ea_kb is an under-estimate real :: max_ea, min_ea real :: err, err_min, err_max real :: derr_dea @@ -1630,6 +1629,9 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & end subroutine F_kb_to_ea_kb +!> This subroutine determines the entrainment from above by the top interior +!! layer (labeled kb elsewhere) given an entrainment by the layer below it, +!! constrained to be within the provided bounds. subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & min_eakb, max_eakb, kmb, is, ie, do_i, G, GV, CS, Ent, & error, err_min_eakb0, err_max_eakb0, F_kb, dFdfm_kb) @@ -1667,19 +1669,19 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & real, dimension(SZI_(G)), intent(inout) :: Ent !< The entrainment rate of the uppermost !! interior layer, in H. The input value !! is the first guess. - real, dimension(SZI_(G)), intent(out), optional :: error !< The error (locally defined in this + real, dimension(SZI_(G)), optional, intent(out) :: error !< The error (locally defined in this !! routine) associated with the returned !! solution. - real, dimension(SZI_(G)), intent(in), optional :: err_min_eakb0, err_max_eakb0 !< The errors + real, dimension(SZI_(G)), optional, intent(in) :: err_min_eakb0, err_max_eakb0 !< The errors !! (locally defined) associated with !! min_eakb and max_eakb when ea_kbp1 !! = 0, returned from a previous call !! to this routine. - real, dimension(SZI_(G)), intent(out), optional :: F_kb !< The entrainment from below by the + real, dimension(SZI_(G)), optional, intent(out) :: F_kb !< The entrainment from below by the !! uppermost interior layer !! corresponding to the returned !! value of Ent, in H. - real, dimension(SZI_(G)), intent(out), optional :: dFdfm_kb !< The partial derivative of F_kb with + real, dimension(SZI_(G)), optional, intent(out) :: dFdfm_kb !< The partial derivative of F_kb with !! ea_kbp1, nondim. ! Arguments: h_bl - Layer thickness, with the top interior layer at k-index @@ -1868,71 +1870,49 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & end subroutine determine_Ea_kb +!> Maximize F = ent*ds_kb*I_dSkbp1 in the range min_ent < ent < max_ent. subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & kmb, is, ie, G, GV, CS, maxF, ent_maxF, do_i_in, & F_lim_maxent, F_thresh) - 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(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),SZK_(G)), & - intent(in) :: h_bl !< Layer thickness, in m or kg m-2 - !! (abbreviated as H below). + intent(in) :: h_bl !< Layer thickness, in m or kg m-2 + !! (abbreviated as H below). real, dimension(SZI_(G),SZK_(G)), & - intent(in) :: Sref !< Reference potential density (in kg m-3?). + intent(in) :: Sref !< Reference potential density (in kg m-3?). real, dimension(SZI_(G),SZK_(G)), & - intent(in) :: Ent_bl !< The average entrainment upward and - !! downward across each interface around - !! the buffer layers, in H. - real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in - !! reference potential density across the - !! base of the uppermost interior layer, - !! in units of m3 kg-1. - real, dimension(SZI_(G)), intent(in) :: min_ent_in !< The minimum value of ent to search, - !! in H. - real, dimension(SZI_(G)), intent(in) :: max_ent_in !< The maximum value of ent to search, - !! in H. - integer, intent(in) :: kmb - integer, intent(in) :: is, ie !< The range of i-indices to work on. - type(entrain_diffusive_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G)), intent(out) :: maxF !< The maximum value of F - !! = ent*ds_kb*I_dSkbp1 found in the range - !! min_ent < ent < max_ent, in H. - real, dimension(SZI_(G)), intent(out), & - optional :: ent_maxF !< The value of ent at that maximum, in H. - logical, dimension(SZI_(G)), intent(in), & - optional :: do_i_in !< A logical array indicating which columns - !! to work on. - real, dimension(SZI_(G)), intent(out), & - optional :: F_lim_maxent !< If present, do not apply the limit in - !! finding the maximum value, but return the - !! limited value at ent=max_ent_in in this - !! array, in H. - real, dimension(SZI_(G)), intent(in), & - optional :: F_thresh !< If F_thresh is present, return the first - !! value found that has F > F_thresh, or - !! the maximum. - -! Arguments: h_bl - Layer thickness, in m or kg m-2 (abbreviated as H below). -! (in) Sref - Reference potential density (in kg m-3?) -! (in) Ent_bl - The average entrainment upward and downward across -! each interface around the buffer layers, in H. -! (in) I_dSkbp1 - The inverse of the difference in reference potential -! density across the base of the uppermost interior layer, -! in units of m3 kg-1. -! (in) min_ent_in - The minimum value of ent to search, in H. -! (in) max_ent_in - The maximum value of ent to search, in H. -! (in) is, ie - The range of i-indices to work on. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) CS - This module's control structure. -! (out) maxF - The maximum value of F = ent*ds_kb*I_dSkbp1 found in the -! range min_ent < ent < max_ent, in H. -! (out,opt) ent_maxF - The value of ent at that maximum, in H. -! (in, opt) do_i_in - A logical array indicating which columns to work on. -! (out,opt) F_lim_maxent - If present, do not apply the limit in finding the -! maximum value, but return the limited value at -! ent=max_ent_in in this array, in H. -! (in, opt) F_thresh - If F_thresh is present, return the first value found -! that has F > F_thresh, or the maximum. + intent(in) :: Ent_bl !< The average entrainment upward and + !! downward across each interface around + !! the buffer layers, in H. + real, dimension(SZI_(G)), intent(in) :: I_dSkbp1 !< The inverse of the difference in + !! reference potential density across the + !! base of the uppermost interior layer, + !! in units of m3 kg-1. + real, dimension(SZI_(G)), intent(in) :: min_ent_in !< The minimum value of ent to search, + !! in H. + real, dimension(SZI_(G)), intent(in) :: max_ent_in !< The maximum value of ent to search, + !! in H. + integer, intent(in) :: kmb + integer, intent(in) :: is, ie !< The range of i-indices to work on. + type(entrain_diffusive_CS), pointer :: CS !< This module's control structure. + real, dimension(SZI_(G)), intent(out) :: maxF !< The maximum value of F + !! = ent*ds_kb*I_dSkbp1 found in the range + !! min_ent < ent < max_ent, in H. + real, dimension(SZI_(G)), & + optional, intent(out) :: ent_maxF !< The value of ent at that maximum, in H. + logical, dimension(SZI_(G)), & + optional, intent(in) :: do_i_in !< A logical array indicating which columns + !! to work on. + real, dimension(SZI_(G)), & + optional, intent(out) :: F_lim_maxent !< If present, do not apply the limit in + !! finding the maximum value, but return the + !! limited value at ent=max_ent_in in this + !! array, in H. + real, dimension(SZI_(G)), & + optional, intent(in) :: F_thresh !< If F_thresh is present, return the first + !! value found that has F > F_thresh, or + !! the maximum. ! Maximize F = ent*ds_kb*I_dSkbp1 in the range min_ent < ent < max_ent. ! ds_kb may itself be limited to positive values in determine_dSkb, which gives @@ -2109,7 +2089,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & new_min_bound = .false. ! We have a new maximum bound. else ! This case would bracket a minimum. Wierd. ! Unless the derivative indicates that there is a maximum near the - ! lower bound, try keeping the end with the larger value of F; + ! lower bound, try keeping the end with the larger value of F ! in a tie keep the minimum as the answer here will be compared ! with the maximum input value later. new_min_bound = .true. diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 06e327b69e..7cb7dc5dc7 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -57,7 +57,7 @@ module MOM_geothermal ! W m-2. real :: geothermal_thick ! The thickness over which geothermal heating is ! applied, in m. - logical :: apply_geothermal ! If true, geothermal heating will be applied; + logical :: apply_geothermal ! If true, geothermal heating will be applied ! otherwise GEOTHERMAL_SCALE has been set to 0 and ! there is no heat to apply. @@ -171,7 +171,7 @@ subroutine geothermal(h, tv, dt, ea, eb, G, GV, CS) H_neglect = GV%H_subroundoff p_ref(:) = tv%P_Ref - if (.not.ASSOCIATED(tv%T)) call MOM_error(FATAL, "MOM geothermal: "//& + if (.not.associated(tv%T)) call MOM_error(FATAL, "MOM geothermal: "//& "Geothermal heating can only be applied if T & S are state variables.") ! do i=is,ie ; do j=js,je diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index e65af9183c..3c9188b6bb 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -372,7 +372,7 @@ subroutine int_tide_input_init(Time, G, GV, param_file, diag, CS, itide) ! Compute the fixed part of internal tidal forcing; units are [J m-2] here. CS%TKE_itidal_coef(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 - enddo; enddo + enddo ; enddo CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 6794d7b45b..3344f218bc 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -1839,7 +1839,8 @@ logical function kappa_shear_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "DEBUG_KAPPA_SHEAR", CS%debug, & "If true, write debugging data for the kappa-shear code. \n"//& "Caution: this option is _very_ verbose and should only \n"//& - "be used in single-column mode!", default=.false.) + "be used in single-column mode!", & + default=.false., debuggingParam=.true.) ! id_clock_KQ = cpu_clock_id('Ocean KS kappa_shear',grain=CLOCK_ROUTINE) ! id_clock_avg = cpu_clock_id('Ocean KS avg',grain=CLOCK_ROUTINE) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 726d139d65..ef6c160f9f 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -78,8 +78,6 @@ module MOM_opacity ! The default is 10 m-1 - a value for muddy water. integer :: sbc_chl ! An integer handle used in time interpolation of ! chlorophyll read from a file. - character(len=128) :: chl_file ! Data containing chl_a concentrations. Used - ! when var_pen_sw is defined and reading from file. logical :: chl_from_file ! If true, chl_a is read from a file. type(time_type), pointer :: Time ! A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag ! A structure that is used to regulate the @@ -102,14 +100,15 @@ module MOM_opacity contains subroutine set_opacity(optics, fluxes, G, GV, CS) - type(optics_type), intent(inout) :: optics - type(forcing), intent(in) :: fluxes !< A structure containing pointers to any - !! possible forcing fields. Unused fields - !! have NULL ptrs. - 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(opacity_CS), pointer :: CS !< The control structure earlier set up by - !! opacity_init. + type(optics_type), intent(inout) :: optics !< An optics structure that has values + !! set based on the opacities. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + 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(opacity_CS), pointer :: CS !< The control structure earlier set up by + !! opacity_init. ! Arguments: (inout) opacity - The inverse of the vertical absorption decay ! scale for penetrating shortwave radiation, in m-1. @@ -149,47 +148,45 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) ! Make sure there is no division by 0. inv_sw_pen_scale = 1.0 / max(CS%pen_sw_scale, 0.1*GV%Angstrom_z, & GV%H_to_m*GV%H_subroundoff) -!$OMP parallel default(none) shared(is,ie,js,je,nz,optics,inv_sw_pen_scale,fluxes,CS,Inv_nbands,GV) if ( CS%Opacity_scheme == DOUBLE_EXP ) then -!$OMP do + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = inv_sw_pen_scale optics%opacity_band(2,i,j,k) = 1.0 / max(CS%pen_sw_scale_2nd, & 0.1*GV%Angstrom_z,GV%H_to_m*GV%H_subroundoff) enddo ; enddo ; enddo if (.not.associated(fluxes%sw) .or. (CS%pen_SW_scale <= 0.0)) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ; do n=1,optics%nbands optics%sw_pen_band(n,i,j) = 0.0 enddo ; enddo ; enddo else -!$OMP do - do j=js,je ; do i=is,ie ; + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie optics%sw_pen_band(1,i,j) = (CS%SW_1st_EXP_RATIO) * fluxes%sw(i,j) optics%sw_pen_band(2,i,j) = (1.-CS%SW_1st_EXP_RATIO) * fluxes%sw(i,j) - enddo ; enddo ; + enddo ; enddo endif else do k=1,nz ; do j=js,je ; do i=is,ie ; do n=1,optics%nbands optics%opacity_band(n,i,j,k) = inv_sw_pen_scale enddo ; enddo ; enddo ; enddo if (.not.associated(fluxes%sw) .or. (CS%pen_SW_scale <= 0.0)) then -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ; do n=1,optics%nbands optics%sw_pen_band(n,i,j) = 0.0 enddo ; enddo ; enddo else -!$OMP do + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie ; do n=1,optics%nbands optics%sw_pen_band(n,i,j) = CS%pen_SW_frac * Inv_nbands * fluxes%sw(i,j) enddo ; enddo ; enddo endif endif -!$OMP end parallel endif if (query_averaging_enabled(CS%diag)) then if (CS%id_sw_pen > 0) then -!$OMP parallel do default(none) shared(is,ie,js,je,Pen_SW_tot,optics) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie Pen_SW_tot(i,j) = 0.0 do n=1,optics%nbands @@ -200,7 +197,7 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) endif if (CS%id_sw_vis_pen > 0) then if (CS%opacity_scheme == MANIZZA_05) then -!$OMP parallel do default(none) shared(is,ie,js,je,Pen_SW_tot,optics) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie Pen_SW_tot(i,j) = 0.0 do n=1,min(optics%nbands,2) @@ -208,7 +205,7 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) enddo enddo ; enddo else -!$OMP parallel do default(none) shared(is,ie,js,je,Pen_SW_tot,optics) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie Pen_SW_tot(i,j) = 0.0 do n=1,optics%nbands @@ -219,7 +216,7 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) call post_data(CS%id_sw_vis_pen, Pen_SW_tot, CS%diag) endif do n=1,optics%nbands ; if (CS%id_opacity(n) > 0) then -!$OMP parallel do default(none) shared(nz,is,ie,js,je,tmp,optics,n) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie tmp(i,j,k) = optics%opacity_band(n,i,j,k) enddo ; enddo ; enddo @@ -231,21 +228,16 @@ end subroutine set_opacity subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) - type(optics_type), intent(inout) :: optics - type(forcing), intent(in) :: fluxes !< A structure containing pointers to any - !! possible forcing fields. Unused fields - !! have NULL ptrs. - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(opacity_CS), pointer :: CS !< The control structure. + type(optics_type), intent(inout) :: optics !< An optics structure that has values + !! set based on the opacities. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to any + !! possible forcing fields. Unused fields + !! have NULL ptrs. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(opacity_CS), pointer :: CS !< The control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in), optional :: chl_in !< A 3-d field of chlorophyll A, - !! in mg m-3. -! Arguments: fluxes - A structure containing pointers to any possible -! forcing fields. Unused fields have NULL ptrs. -! (out) opacity - The inverse of the vertical absorption decay -! scale for penetrating shortwave radiation, in m-1. -! (in) G - The ocean's grid structure. -! (in) chl_in - A 3-d field of chlorophyll A, in mg m-3. + optional, intent(in) :: chl_in !< A 3-d field of chlorophyll A, + !! in mg m-3. real :: chl_data(SZI_(G),SZJ_(G)) ! The chlorophyll A concentrations in ! a layer, in mg/m^3. @@ -294,7 +286,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) associated(fluxes%sw_nir_dif)) chl_data(:,:) = 0.0 - if(present(chl_in)) then + if (present(chl_in)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_in(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_in(i,j,k) < 0.0)) then @@ -303,7 +295,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) chl_in(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(FATAL,"MOM_opacity opacity_from_chl: "//trim(mesg)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo else ! Only the 2-d surface chlorophyll can be read in from a file. The ! same value is assumed for all layers. @@ -320,7 +312,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) endif if (CS%id_chl > 0) then - if(present(chl_in)) then + if (present(chl_in)) then call post_data(CS%id_chl, chl_in(:,:,1), CS%diag) else call post_data(CS%id_chl, chl_data, CS%diag) @@ -376,7 +368,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) enddo enddo ; enddo case default - call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") + call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") end select !$OMP parallel do default(none) shared(nz,is,ie,js,je,CS,G,chl_in,optics,nbands) & @@ -478,7 +470,8 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) target, intent(in) :: tracer_flow type(opacity_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module. - type(optics_type), pointer :: optics + type(optics_type), pointer :: optics !< An optics structure that has parameters + !! set and arrays allocated here. ! Arguments: Time - The current model time. ! (in) G - The ocean's grid structure. ! (in) param_file - A structure indicating the open file to parse for @@ -497,6 +490,9 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) character(len=200) :: longname character(len=40) :: scheme_string logical :: use_scheme + 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. integer :: isd, ied, jsd, jed, nz, n isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = G%ke @@ -511,7 +507,7 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) CS%tracer_flow_CSp => tracer_flow ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") + call log_version(param_file, mdl, version, '') ! parameters for CHL_A routines call get_param(param_file, mdl, "VAR_PEN_SW", CS%var_pen_sw, & @@ -519,7 +515,7 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) "OPACITY_SCHEME to determine the e-folding depth of \n"//& "incoming short wave radiation.", default=.false.) - CS%opacity_scheme = NO_SCHEME ; scheme_string = "" + CS%opacity_scheme = NO_SCHEME ; scheme_string = '' if (CS%var_pen_sw) then call get_param(param_file, mdl, "OPACITY_SCHEME", tmpstr, & "This character string specifies how chlorophyll \n"//& @@ -553,14 +549,15 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) call time_interp_external_init() call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") - call get_param(param_file, mdl, "CHL_FILE", CS%chl_file, & + call get_param(param_file, mdl, "CHL_FILE", chl_file, & "CHL_FILE is the file containing chl_a concentrations in \n"//& "the variable CHL_A. It is used when VAR_PEN_SW and \n"//& "CHL_FROM_FILE are true.", fail_if_missing=.true.) - - filename = trim(slasher(inputdir))//trim(CS%chl_file) + filename = trim(slasher(inputdir))//trim(chl_file) call log_param(param_file, mdl, "INPUTDIR/CHL_FILE", filename) - CS%sbc_chl = init_external_field(filename,'CHL_A',domain=G%Domain%mpp_domain) + call get_param(param_file, mdl, "CHL_VARNAME", chl_varname, & + "Name of CHL_A variable in CHL_FILE.", default='CHL_A') + CS%sbc_chl = init_external_field(filename,trim(chl_varname),domain=G%Domain%mpp_domain) endif call get_param(param_file, mdl, "BLUE_FRAC_SW", CS%blue_frac, & @@ -612,19 +609,19 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) "The number of bands of penetrating shortwave radiation.", & default=1) if (CS%Opacity_scheme == DOUBLE_EXP ) then - if (optics%nbands.ne.2) then + if (optics%nbands /= 2) then call MOM_error(FATAL, "set_opacity: "// & "Cannot use a double_exp opacity scheme with nbands!=2.") endif elseif (CS%Opacity_scheme == SINGLE_EXP ) then - if (optics%nbands.ne.1) then + if (optics%nbands /= 1) then call MOM_error(FATAL, "set_opacity: "// & "Cannot use a single_exp opacity scheme with nbands!=1.") endif endif - if (.not.ASSOCIATED(optics%min_wavelength_band)) & + if (.not.associated(optics%min_wavelength_band)) & allocate(optics%min_wavelength_band(optics%nbands)) - if (.not.ASSOCIATED(optics%max_wavelength_band)) & + if (.not.associated(optics%max_wavelength_band)) & allocate(optics%max_wavelength_band(optics%nbands)) if (CS%opacity_scheme == MANIZZA_05) then @@ -646,9 +643,9 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) "The value to use for opacity over land. The default is \n"//& "10 m-1 - a value for muddy water.", units="m-1", default=10.0) - if (.not.ASSOCIATED(optics%opacity_band)) & + if (.not.associated(optics%opacity_band)) & allocate(optics%opacity_band(optics%nbands,isd:ied,jsd:jed,nz)) - if (.not.ASSOCIATED(optics%sw_pen_band)) & + if (.not.associated(optics%sw_pen_band)) & allocate(optics%sw_pen_band(optics%nbands,isd:ied,jsd:jed)) allocate(CS%id_opacity(optics%nbands)) ; CS%id_opacity(:) = -1 @@ -672,15 +669,15 @@ end subroutine opacity_init subroutine opacity_end(CS, optics) - type(opacity_CS), pointer :: CS - type(optics_type), pointer, optional :: optics + type(opacity_CS), pointer :: CS !< An opacity control structure that should be deallocated. + type(optics_type), optional, pointer :: optics !< An optics type structure that should be deallocated. if (associated(CS%id_opacity)) deallocate(CS%id_opacity) if (associated(CS)) deallocate(CS) if (present(optics)) then ; if (associated(optics)) then - if (ASSOCIATED(optics%opacity_band)) deallocate(optics%opacity_band) - if (ASSOCIATED(optics%sw_pen_band)) deallocate(optics%sw_pen_band) + if (associated(optics%opacity_band)) deallocate(optics%opacity_band) + if (associated(optics%sw_pen_band)) deallocate(optics%sw_pen_band) endif ; endif end subroutine opacity_end diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 950c3f5f34..a06c25b8f3 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -109,7 +109,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, CS) !! layer detrainment, in the same units as !! h - usually m or kg m-2 (i.e., H). real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: eb !< The amount of fluid moved upward into a layer; + intent(inout) :: eb !< The amount of fluid moved upward into a layer !! this should be increased due to mixed layer !! entrainment, in the same units as h - usually !! m or kg m-2 (i.e., H). @@ -168,7 +168,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) !! layer detrainment, in the same units as h - !! usually m or kg m-2 (i.e., H). real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: eb !< The amount of fluid moved upward into a layer; + intent(inout) :: eb !< The amount of fluid moved upward into a layer !! this should be increased due to mixed layer !! entrainment, in the same units as h - usually !! m or kg m-2 (i.e., H). @@ -277,7 +277,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) if (GV%nkml<1) return nkmb = GV%nk_rho_varies ; nkml = GV%nkml - if (.not.ASSOCIATED(tv%eqn_of_state)) call MOM_error(FATAL, & + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, & "MOM_regularize_layers: This module now requires the use of temperature and "//& "an equation of state.") @@ -1062,7 +1062,7 @@ subroutine regularize_layers_init(Time, G, param_file, diag, CS) Time, 'V-point filtered 2-layer thickness deficit ratio', 'nondim') #endif - if(CS%allow_clocks_in_omp_loops) then + if (CS%allow_clocks_in_omp_loops) then id_clock_EOS = cpu_clock_id('(Ocean regularize_layers EOS)', grain=CLOCK_ROUTINE) endif id_clock_pass = cpu_clock_id('(Ocean regularize_layers halo updates)', grain=CLOCK_ROUTINE) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index da5fcfd03a..abdd27881b 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -23,6 +23,8 @@ module MOM_set_diffusivity use MOM_kappa_shear, only : calculate_kappa_shear, kappa_shear_init, Kappa_shear_CS use MOM_CVMix_shear, only : calculate_CVMix_shear, CVMix_shear_init, CVMix_shear_cs use MOM_CVMix_shear, only : CVMix_shear_end +use MOM_CVMix_ddiff, only : CVMix_ddiff_init, CVMix_ddiff_end, CVMix_ddiff_cs +use MOM_CVMix_ddiff, only : compute_ddiff_coeffs use MOM_bkgnd_mixing, only : calculate_bkgnd_mixing, bkgnd_mixing_init, bkgnd_mixing_cs use MOM_bkgnd_mixing, only : bkgnd_mixing_end, sfc_bkgnd_mixing use MOM_string_functions, only : uppercase @@ -43,125 +45,114 @@ module MOM_set_diffusivity public set_diffusivity_end type, public :: set_diffusivity_CS ; private - logical :: debug ! If true, write verbose checksums for debugging. - - logical :: bulkmixedlayer ! If true, a refined bulk mixed layer is used with - ! GV%nk_rho_varies variable density mixed & buffer - ! layers. - real :: FluxRi_max ! The flux Richardson number where the stratification is - ! large enough that N2 > omega2. The full expression for - ! the Flux Richardson number is usually - ! FLUX_RI_MAX*N2/(N2+OMEGA2). The default is 0.2. - logical :: bottomdraglaw ! If true, the bottom stress is calculated with a - ! drag law c_drag*|u|*u. - logical :: BBL_mixing_as_max ! If true, take the maximum of the diffusivity - ! from the BBL mixing and the other diffusivities. - ! Otherwise, diffusivities from the BBL_mixing is - ! added. - logical :: use_LOTW_BBL_diffusivity ! If true, use simpler/less precise, BBL diffusivity. - logical :: LOTW_BBL_use_omega ! If true, use simpler/less precise, BBL diffusivity. - real :: BBL_effic ! efficiency with which the energy extracted - ! by bottom drag drives BBL diffusion (nondim) - real :: cdrag ! quadratic drag coefficient (nondim) - real :: IMax_decay ! inverse of a maximum decay scale for - ! bottom-drag driven turbulence, (1/m) - - real :: Kd ! interior diapycnal diffusivity (m2/s) - real :: Kd_min ! minimum diapycnal diffusivity (m2/s) - real :: Kd_max ! maximum increment for diapycnal diffusivity (m2/s) - ! Set to a negative value to have no limit. - real :: Kd_add ! uniform diffusivity added everywhere without - ! filtering or scaling (m2/s) - real :: Kv ! interior vertical viscosity (m2/s) - real :: Kdml ! mixed layer diapycnal diffusivity (m2/s) - ! when bulkmixedlayer==.false. - real :: Hmix ! mixed layer thickness (meter) when - ! bulkmixedlayer==.false. + logical :: debug !< If true, write verbose checksums for debugging. + + logical :: bulkmixedlayer !< If true, a refined bulk mixed layer is used with + !! GV%nk_rho_varies variable density mixed & buffer + !! layers. + real :: FluxRi_max !< The flux Richardson number where the stratification is + !! large enough that N2 > omega2. The full expression for + !! the Flux Richardson number is usually + !! FLUX_RI_MAX*N2/(N2+OMEGA2). The default is 0.2. + logical :: bottomdraglaw !< If true, the bottom stress is calculated with a + !! drag law c_drag*|u|*u. + logical :: BBL_mixing_as_max !< If true, take the maximum of the diffusivity + !! from the BBL mixing and the other diffusivities. + !! Otherwise, diffusivities from the BBL_mixing is + !! added. + logical :: use_LOTW_BBL_diffusivity !< If true, use simpler/less precise, BBL diffusivity. + logical :: LOTW_BBL_use_omega !< If true, use simpler/less precise, BBL diffusivity. + real :: BBL_effic !< efficiency with which the energy extracted + !! by bottom drag drives BBL diffusion (nondim) + real :: cdrag !< quadratic drag coefficient (nondim) + real :: IMax_decay !< inverse of a maximum decay scale for + !! bottom-drag driven turbulence, (1/m) + real :: Kv !< The interior vertical viscosity (m2/s) + real :: Kd !< interior diapycnal diffusivity (m2/s) + real :: Kd_min !< minimum diapycnal diffusivity (m2/s) + real :: Kd_max !< maximum increment for diapycnal diffusivity (m2/s) + !! Set to a negative value to have no limit. + real :: Kd_add !< uniform diffusivity added everywhere without + !! filtering or scaling (m2/s) + real :: Kdml !< mixed layer diapycnal diffusivity (m2/s) + !! when bulkmixedlayer==.false. + real :: Hmix !< mixed layer thickness (meter) when + !! bulkmixedlayer==.false. type(diag_ctrl), pointer :: diag ! structure to regulate diagn output timing - logical :: limit_dissipation ! If enabled, dissipation is limited to be larger - ! than the following: - real :: dissip_min ! Minimum dissipation (W/m3) - real :: dissip_N0 ! Coefficient a in minimum dissipation = a+b*N (W/m3) - real :: dissip_N1 ! Coefficient b in minimum dissipation = a+b*N (J/m3) - real :: dissip_N2 ! Coefficient c in minimum dissipation = c*N2 (W m-3 s2) - real :: dissip_Kd_min ! Minimum Kd (m2/s) with dissipatio Rho0*Kd_min*N^2 - - real :: TKE_itide_max ! maximum internal tide conversion (W m-2) - ! available to mix above the BBL - real :: omega ! Earth's rotation frequency (s-1) - logical :: ML_radiation ! allow a fraction of TKE available from wind work - ! to penetrate below mixed layer base with a vertical - ! decay scale determined by the minimum of - ! (1) The depth of the mixed layer, or - ! (2) An Ekman length scale. - ! Energy availble to drive mixing below the mixed layer is - ! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if - ! ML_rad_TKE_decay is true, this is further reduced by a factor - ! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is - ! calculated the same way as in the mixed layer code. - ! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), - ! where N2 is the squared buoyancy frequency (s-2) and OMEGA2 - ! is the rotation rate of the earth squared. - real :: ML_rad_kd_max ! Maximum diapycnal diffusivity due to turbulence - ! radiated from the base of the mixed layer (m2/s) - real :: ML_rad_efold_coeff ! non-dim coefficient to scale penetration depth - real :: ML_rad_coeff ! coefficient, which scales MSTAR*USTAR^3 to - ! obtain energy available for mixing below - ! mixed layer base (nondimensional) - logical :: ML_rad_TKE_decay ! If true, apply same exponential decay - ! to ML_rad as applied to the other surface - ! sources of TKE in the mixed layer code. - real :: ustar_min ! A minimum value of ustar to avoid numerical - ! problems (m/s). If the value is small enough, - ! this parameter should not affect the solution. - real :: TKE_decay ! ratio of natural Ekman depth to TKE decay scale (nondim) - real :: mstar ! ratio of friction velocity cubed to - ! TKE input to the mixed layer (nondim) - logical :: ML_use_omega ! If true, use absolute rotation rate instead - ! of the vertical component of rotation when - ! setting the decay scale for mixed layer turbulence. - real :: ML_omega_frac ! When setting the decay scale for turbulence, use - ! this fraction of the absolute rotation rate blended - ! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. - logical :: user_change_diff ! If true, call user-defined code to change diffusivity. - logical :: useKappaShear ! If true, use the kappa_shear module to find the - ! shear-driven diapycnal diffusivity. - logical :: use_CVMix_shear ! If true, use one of the CVMix modules to find - ! shear-driven diapycnal diffusivity. - logical :: double_diffusion ! If true, enable double-diffusive mixing. - logical :: simple_TKE_to_Kd ! If true, uses a simple estimate of Kd/TKE that - ! does not rely on a layer-formulation. - real :: Max_Rrho_salt_fingers ! max density ratio for salt fingering - real :: Max_salt_diff_salt_fingers ! max salt diffusivity for salt fingers (m2/s) - real :: Kv_molecular ! molecular visc for double diff convect (m2/s) + logical :: limit_dissipation !< If enabled, dissipation is limited to be larger + !! than the following: + real :: dissip_min !< Minimum dissipation (W/m3) + real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N (W/m3) + real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N (J/m3) + real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 (W m-3 s2) + real :: dissip_Kd_min !< Minimum Kd (m2/s) with dissipatio Rho0*Kd_min*N^2 + + real :: TKE_itide_max !< maximum internal tide conversion (W m-2) + !! available to mix above the BBL + real :: omega !< Earth's rotation frequency (s-1) + logical :: ML_radiation !< allow a fraction of TKE available from wind work + !! to penetrate below mixed layer base with a vertical + !! decay scale determined by the minimum of + !! (1) The depth of the mixed layer, or + !! (2) An Ekman length scale. + !! Energy availble to drive mixing below the mixed layer is + !! given by E = ML_RAD_COEFF*MSTAR*USTAR**3. Optionally, if + !! ML_rad_TKE_decay is true, this is further reduced by a factor + !! of exp(-h_ML*Idecay_len_TkE), where Idecay_len_TKE is + !! calculated the same way as in the mixed layer code. + !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), + !! where N2 is the squared buoyancy frequency (s-2) and OMEGA2 + !! is the rotation rate of the earth squared. + real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence + !! radiated from the base of the mixed layer (m2/s) + real :: ML_rad_efold_coeff !< non-dim coefficient to scale penetration depth + real :: ML_rad_coeff !< coefficient, which scales MSTAR*USTAR^3 to + !! obtain energy available for mixing below + !! mixed layer base (nondimensional) + logical :: ML_rad_TKE_decay !< If true, apply same exponential decay + !! to ML_rad as applied to the other surface + !! sources of TKE in the mixed layer code. + real :: ustar_min !< A minimum value of ustar to avoid numerical + !! problems (m/s). If the value is small enough, + !! this parameter should not affect the solution. + real :: TKE_decay !< ratio of natural Ekman depth to TKE decay scale (nondim) + real :: mstar !! ratio of friction velocity cubed to + !! TKE input to the mixed layer (nondim) + logical :: ML_use_omega !< If true, use absolute rotation rate instead + !! of the vertical component of rotation when + !! setting the decay scale for mixed layer turbulence. + real :: ML_omega_frac !< When setting the decay scale for turbulence, use + !! this fraction of the absolute rotation rate blended + !! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. + logical :: user_change_diff !< If true, call user-defined code to change diffusivity. + logical :: useKappaShear !< If true, use the kappa_shear module to find the + !! shear-driven diapycnal diffusivity. + logical :: use_CVMix_shear !< If true, use one of the CVMix modules to find + !! shear-driven diapycnal diffusivity. + logical :: double_diffusion !< If true, enable double-diffusive mixing using an old method. + logical :: use_CVMix_ddiff !< If true, enable double-diffusive mixing via CVMix. + logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that + !! does not rely on a layer-formulation. + real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering + real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers (m2/s) + real :: Kv_molecular !< molecular visc for double diff convect (m2/s) character(len=200) :: inputdir type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() type(diag_to_Z_CS), pointer :: diag_to_Z_CSp => NULL() type(Kappa_shear_CS), pointer :: kappaShear_CSp => NULL() type(CVMix_shear_cs), pointer :: CVMix_shear_csp => NULL() + type(CVMix_ddiff_cs), pointer :: CVMix_ddiff_csp => NULL() type(bkgnd_mixing_cs), pointer :: bkgnd_mixing_csp => NULL() type(int_tide_CS), pointer :: int_tide_CSp => NULL() type(tidal_mixing_cs), pointer :: tm_csp => NULL() - integer :: id_maxTKE = -1 - integer :: id_TKE_to_Kd = -1 - - integer :: id_Kd_user = -1 - integer :: id_Kd_layer = -1 - integer :: id_Kd_BBL = -1 - integer :: id_Kd_BBL_z = -1 - integer :: id_Kd_user_z = -1 - integer :: id_Kd_Work = -1 - - integer :: id_N2 = -1 - integer :: id_N2_z = -1 - - integer :: id_KT_extra = -1 - integer :: id_KS_extra = -1 - integer :: id_KT_extra_z = -1 - integer :: id_KS_extra_z = -1 + integer :: id_maxTKE = -1, id_TKE_to_Kd = -1, id_Kd_user = -1 + integer :: id_Kd_layer = -1, id_Kd_BBL = -1, id_Kd_BBL_z = -1 + integer :: id_Kd_user_z = -1, id_N2 = -1, id_N2_z = -1 + integer :: id_Kd_Work = -1, id_KT_extra = -1, id_KS_extra = -1 + integer :: id_KT_extra_z = -1, id_KS_extra_z = -1 end type set_diffusivity_CS @@ -181,10 +172,20 @@ module MOM_set_diffusivity end type diffusivity_diags ! Clocks -integer :: id_clock_kappaShear +integer :: id_clock_kappaShear, id_clock_CVMix_ddiff contains +!> Sets the interior vertical diffusion of scalars due to the following processes: +!! 1) Shear-driven mixing: two options, Jackson et at. and KPP interior; +!! 2) Background mixing via CVMix (Bryan-Lewis profile) or the scheme described by +!! Harrison & Hallberg, JPO 2008; +!! 3) Double-diffusion, old method and new method via CVMix; +!! 4) Tidal mixing: many options available, see MOM_tidal_mixing.F90; +!! In addition, this subroutine has the option to set the interior vertical +!! viscosity associated with processes 1,2 and 4 listed above, which is stored in +!! visc%Kv_slow. Vertical viscosity due to shear-driven mixing is passed via +!! visc%Kv_shear subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & G, GV, CS, Kd, Kd_int) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -196,9 +197,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u_h + intent(in) :: u_h !< zonal thickness transport m^2/s. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: v_h + intent(in) :: v_h !< meridional thickness transport m^2/s. type(thermo_var_ptrs), intent(inout) :: tv !< Structure with pointers to thermodynamic !! fields. Out is for tv%TempxPmE. type(forcing), intent(in) :: fluxes !< Structure of surface fluxes that may be @@ -222,20 +223,20 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & type(diffusivity_diags) :: dd ! structure w/ arrays of pointers to avail diags real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - T_f, S_f ! temperature and salinity (deg C and ppt); + T_f, S_f ! temperature and salinity (deg C and ppt) ! massless layers filled vertically by diffusion. real, dimension(SZI_(G),SZK_(G)) :: & - N2_lay, & ! squared buoyancy frequency associated with layers (1/s2) - maxTKE, & ! energy required to entrain to h_max (m3/s3) - TKE_to_Kd ! conversion rate (~1.0 / (G_Earth + dRho_lay)) between - ! TKE dissipated within a layer and Kd in that layer, in - ! m2 s-1 / m3 s-3 = s2 m-1. + N2_lay, & !< squared buoyancy frequency associated with layers (1/s2) + maxTKE, & !< energy required to entrain to h_max (m3/s3) + TKE_to_Kd !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between + !< TKE dissipated within a layer and Kd in that layer, in + !< m2 s-1 / m3 s-3 = s2 m-1. real, dimension(SZI_(G),SZK_(G)+1) :: & - N2_int, & ! squared buoyancy frequency associated at interfaces (1/s2) - dRho_int, & ! locally ref potential density difference across interfaces (in s-2) smg: or kg/m3? - KT_extra, & ! double difusion diffusivity on temperature (m2/sec) + N2_int, & !< squared buoyancy frequency associated at interfaces (1/s2) + dRho_int, & !< locally ref potential density difference across interfaces (in s-2) smg: or kg/m3? + KT_extra, & !< double difusion diffusivity on temperature (m2/sec) KS_extra ! double difusion diffusivity on salinity (m2/sec) real :: I_Rho0 ! inverse of Boussinesq density (m3/kg) @@ -271,10 +272,16 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & use_EOS = associated(tv%eqn_of_state) - if ((CS%double_diffusion) .and. & - .not.(associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S)) ) & - call MOM_error(FATAL, "set_diffusivity: visc%Kd_extra_T and "//& - "visc%Kd_extra_S must be associated when DOUBLE_DIFFUSION is true.") + if ((CS%use_CVMix_ddiff .or. CS%double_diffusion) .and. .not. & + (associated(visc%Kd_extra_T) .and. associated(visc%Kd_extra_S))) & + call MOM_error(FATAL, "set_diffusivity: both visc%Kd_extra_T and "//& + "visc%Kd_extra_S must be associated when USE_CVMIX_DDIFF or DOUBLE_DIFFUSION are true.") + + ! Set Kd, Kd_int and Kv_slow to constant values. + ! If nothing else is specified, this will be the value used. + Kd(:,:,:) = CS%Kd + Kd_int(:,:,:) = CS%Kd + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv ! Set up arrays for diagnostics. @@ -341,6 +348,10 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & elseif (CS%use_CVMix_shear) then !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear,G,GV,CS%CVMix_shear_csp) + if (CS%debug) then + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear",G%HI) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear",G%HI) + endif elseif (associated(visc%Kv_shear)) then visc%Kv_shear(:,:,:) = 0. ! needed if calculate_kappa_shear is not enabled endif @@ -352,14 +363,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! set surface diffusivities (CS%bkgnd_mixing_csp%Kd_sfc) call sfc_bkgnd_mixing(G, CS%bkgnd_mixing_csp) -! GMM, fix OMP calls below - !$OMP parallel do default(none) shared(is,ie,js,je,nz,G,GV,CS,h,tv,T_f,S_f,fluxes,dd, & -!$OMP Kd,Kd_sfc,epsilon,deg_to_rad,I_2Omega,visc, & +!$OMP Kd,visc, & !$OMP Kd_int,dt,u,v,Omega2) & -!$OMP private(dRho_int,I_trans,atan_fn_sfc,I_atan_fn,atan_fn_lay, & -!$OMP I_Hmix,depth_c,depth,N2_lay, N2_int, N2_bot, & -!$OMP I_x30,abs_sin,N_2Omega,N02_N2,KT_extra, KS_extra, & +!$OMP private(dRho_int, & +!$OMP N2_lay, N2_int, N2_bot, & +!$OMP KT_extra, KS_extra, & !$OMP TKE_to_Kd,maxTKE,dissip,kb) do j=js,je @@ -370,10 +379,10 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo endif - ! add background mixing + ! Add background mixing call calculate_bkgnd_mixing(h, tv, N2_lay, Kd, visc%Kv_slow, j, G, GV, CS%bkgnd_mixing_csp) - ! GMM, the following will go into the MOM_CVMix_double_diffusion module + ! Double-diffusion (old method) if (CS%double_diffusion) then call double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, KT_extra, KS_extra) do K=2,nz ; do i=is,ie @@ -391,7 +400,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & visc%Kd_extra_T(i,j,k) = 0.0 visc%Kd_extra_S(i,j,k) = 0.0 endif - enddo; enddo + enddo ; enddo if (associated(dd%KT_extra)) then ; do K=1,nz+1 ; do i=is,ie dd%KT_extra(i,j,K) = KT_extra(i,K) enddo ; enddo ; endif @@ -401,6 +410,14 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & enddo ; enddo ; endif endif + ! Apply double diffusion via CVMix + ! GMM, we need to pass HBL to compute_ddiff_coeffs, but it is not yet available. + if (CS%use_CVMix_ddiff) then + call cpu_clock_begin(id_clock_CVMix_ddiff) + call compute_ddiff_coeffs(h, tv, G, GV, j, visc%Kd_extra_T, visc%Kd_extra_S, CS%CVMix_ddiff_csp) + call cpu_clock_end(id_clock_CVMix_ddiff) + endif + ! Add the input turbulent diffusivity. if (CS%useKappaShear .or. CS%use_CVMix_shear) then if (present(Kd_int)) then @@ -441,7 +458,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & ! Add the Nikurashin and / or tidal bottom-driven mixing call calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, maxTKE, G, GV, CS%tm_csp, & - N2_lay, N2_int, Kd, Kd_int, CS%Kd_max) + N2_lay, N2_int, Kd, Kd_int, CS%Kd_max, visc%Kv_slow) ! This adds the diffusion sustained by the energy extracted from the flow ! by the bottom drag. @@ -496,6 +513,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & if (CS%useKappaShear) call hchksum(visc%Kd_shear,"Turbulent Kd",G%HI,haloshift=0) + if (CS%use_CVMix_ddiff) then + call hchksum(visc%Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T",G%HI,haloshift=0) + call hchksum(visc%Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S",G%HI,haloshift=0) + endif + if (associated(visc%kv_bbl_u) .and. associated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, & G%HI, 0, symmetric=.true.) @@ -512,12 +534,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & endif - ! send bkgnd_mixing diagnostics to post_data - if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) - if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & - call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) - if (CS%Kd_add > 0.0) then if (present(Kd_int)) then !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_int,CS,Kd) @@ -538,13 +554,28 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & T_f, S_f, dd%Kd_user) endif - ! GMM, post diags... - if (CS%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd, CS%diag) + ! post diagnostics - num_z_diags = 0 + ! background mixing + if (CS%bkgnd_mixing_csp%id_kd_bkgnd > 0) & + call post_data(CS%bkgnd_mixing_csp%id_kd_bkgnd, CS%bkgnd_mixing_csp%kd_bkgnd, CS%bkgnd_mixing_csp%diag) + if (CS%bkgnd_mixing_csp%id_kv_bkgnd > 0) & + call post_data(CS%bkgnd_mixing_csp%id_kv_bkgnd, CS%bkgnd_mixing_csp%kv_bkgnd, CS%bkgnd_mixing_csp%diag) + + ! double diffusive mixing + if (CS%CVMix_ddiff_csp%id_KT_extra > 0) & + call post_data(CS%CVMix_ddiff_csp%id_KT_extra, visc%Kd_extra_T, CS%CVMix_ddiff_csp%diag) + if (CS%CVMix_ddiff_csp%id_KS_extra > 0) & + call post_data(CS%CVMix_ddiff_csp%id_KS_extra, visc%Kd_extra_S, CS%CVMix_ddiff_csp%diag) + if (CS%CVMix_ddiff_csp%id_R_rho > 0) & + call post_data(CS%CVMix_ddiff_csp%id_R_rho, CS%CVMix_ddiff_csp%R_rho, CS%CVMix_ddiff_csp%diag) + if (CS%id_Kd_layer > 0) call post_data(CS%id_Kd_layer, Kd, CS%diag) + + ! tidal mixing call post_tidal_diagnostics(G,GV,h,CS%tm_csp) + num_z_diags = 0 if (CS%tm_csp%Int_tide_dissipation .or. CS%tm_csp%Lee_wave_dissipation .or. & CS%tm_csp%Lowmode_itidal_dissipation) then @@ -952,8 +983,6 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, CS, dRho_int, & end subroutine find_N2 -! GMM, the following will be moved to a new module - !> This subroutine sets the additional diffusivities of temperature and !! salinity due to double diffusion, using the same functional form as is !! used in MOM4.1, and taken from an NCAR technical note (REF?) that updates @@ -984,27 +1013,6 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, Kd_T_dd, Kd_S_dd) intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal !! diffusivity for saln (m2/sec). -! Arguments: -! (in) tv - structure containing pointers to any available -! thermodynamic fields; absent fields have NULL ptrs -! (in) h - layer thickness (m or kg m-2) -! (in) T_f - layer temp in C with the values in massless layers -! filled vertically by diffusion -! (in) S_f - layer salinities in PPT with values in massless layers -! filled vertically by diffusion -! (in) G - ocean grid structure -! (in) GV - The ocean's vertical grid structure. -! (in) CS - module control structure -! (in) j - meridional index upon which to work -! (out) Kd_T_dd - interface double diffusion diapycnal diffusivity for temp (m2/sec) -! (out) Kd_S_dd - interface double diffusion diapycnal diffusivity for saln (m2/sec) - -! This subroutine sets the additional diffusivities of temperature and -! salinity due to double diffusion, using the same functional form as is -! used in MOM4.1, and taken from an NCAR technical note (###REF?) that updates -! what was in Large et al. (1994). All the coefficients here should probably -! be made run-time variables rather than hard-coded constants. - real, dimension(SZI_(G)) :: & dRho_dT, & ! partial derivatives of density wrt temp (kg m-3 degC-1) dRho_dS, & ! partial derivatives of density wrt saln (kg m-3 PPT-1) @@ -1065,6 +1073,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, CS, Kd_T_dd, Kd_S_dd) endif end subroutine double_diffusion + !> This routine adds diffusion sustained by flow energy extracted by bottom drag. subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & maxTKE, kb, G, GV, CS, Kd, Kd_int, Kd_BBL) @@ -1139,7 +1148,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! to be relatively small and is discarded. do i=is,ie ustar_h = visc%ustar_BBL(i,j) - if (ASSOCIATED(fluxes%ustar_tidal)) & + if (associated(fluxes%ustar_tidal)) & ustar_h = ustar_h + fluxes%ustar_tidal(i,j) absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) @@ -1154,7 +1163,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & exp(-I2decay(i)*(GV%H_to_m*h(i,j,nz))) ) * & visc%TKE_BBL(i,j) - if (ASSOCIATED(fluxes%TKE_tidal)) & + if (associated(fluxes%TKE_tidal)) & TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_m*h(i,j,nz)))) @@ -1354,7 +1363,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & ustar2 = ustar**2 ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting ! since ustar_BBL should already include all contributions to u*? -AJA - if (ASSOCIATED(fluxes%ustar_tidal)) ustar = ustar + fluxes%ustar_tidal(i,j) + if (associated(fluxes%ustar_tidal)) ustar = ustar + fluxes%ustar_tidal(i,j) ! The maximum decay scale should be something of order 200 m. We use the smaller of u*/f and ! (IMax_decay)^-1 as the decay scale. If ustar = 0, this is land so this value doesn't matter. @@ -1367,7 +1376,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, & TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) ! Add in tidal dissipation energy at the bottom, in m3 s-3. ! Note that TKE_tidal is in W m-2. - if (ASSOCIATED(fluxes%TKE_tidal)) TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * I_Rho0 + if (associated(fluxes%TKE_tidal)) TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * I_Rho0 TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column @@ -1851,7 +1860,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! These default values always need to be set. CS%BBL_mixing_as_max = .true. - CS%Kdml = 0.0 ; CS%cdrag = 0.003 ; CS%BBL_effic = 0.0 ; + CS%Kdml = 0.0 ; CS%cdrag = 0.003 ; CS%BBL_effic = 0.0 CS%bulkmixedlayer = (GV%nkml > 0) @@ -1974,6 +1983,11 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! set params releted to the background mixing call bkgnd_mixing_init(Time, G, GV, param_file, CS%diag, CS%bkgnd_mixing_csp) + call get_param(param_file, mdl, "KV", CS%Kv, & + "The background kinematic viscosity in the interior. \n"//& + "The molecular value, ~1e-6 m2 s-1, may be used.", & + units="m2 s-1", fail_if_missing=.true.) + call get_param(param_file, mdl, "KD", CS%Kd, & "The background diapycnal diffusivity of density in the \n"//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, \n"//& @@ -2015,7 +2029,8 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "mixed layer is not used.", units="m", fail_if_missing=.true.) endif call get_param(param_file, mdl, "DEBUG", CS%debug, & - "If true, write out verbose debugging data.", default=.false.) + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "USER_CHANGE_DIFFUSIVITY", CS%user_change_diff, & "If true, call user-defined code to change the diffusivity.", & @@ -2075,12 +2090,11 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp endif endif - - ! GMM, the following should be moved to the DD module call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & "If true, increase diffusivitives for temperature or salt \n"//& "based on double-diffusive paramaterization from MOM4/KPP.", & default=.false.) + if (CS%double_diffusion) then call get_param(param_file, mdl, "MAX_RRHO_SALT_FINGERS", CS%Max_Rrho_salt_fingers, & "Maximum density ratio for salt fingering regime.", & @@ -2112,7 +2126,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp "Bottom Boundary Layer Diffusivity", z_grid='z') CS%id_Kd_BBL_z = register_Zint_diag(vd, CS%diag_to_Z_CSp, Time) endif - endif + endif ! old double-diffusion if (CS%user_change_diff) then call user_change_diff_init(Time, G, param_file, diag, CS%user_change_diff_CSp) @@ -2129,6 +2143,11 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! CVMix shear-driven mixing CS%use_CVMix_shear = CVMix_shear_init(Time, G, GV, param_file, CS%diag, CS%CVMix_shear_csp) + ! CVMix double diffusion mixing + CS%use_CVMix_ddiff = CVMix_ddiff_init(Time, G, GV, param_file, CS%diag, CS%CVMix_ddiff_csp) + if (CS%use_CVMix_ddiff) & + id_clock_CVMix_ddiff = cpu_clock_id('(Double diffusion via CVMix)', grain=CLOCK_MODULE) + end subroutine set_diffusivity_init !> Clear pointers and dealocate memory @@ -2145,6 +2164,9 @@ subroutine set_diffusivity_end(CS) if (CS%use_CVMix_shear) & call CVMix_shear_end(CS%CVMix_shear_csp) + if (CS%use_CVMix_ddiff) & + call CVMix_ddiff_end(CS%CVMix_ddiff_csp) + if (associated(CS)) deallocate(CS) end subroutine set_diffusivity_end diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 90401313dc..427a0284ba 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2,38 +2,6 @@ module MOM_set_visc ! This file is part of MOM6. See LICENSE.md for the license. -!********+*********+*********+*********+*********+*********+*********+** -!* * -!* By Robert Hallberg, April 1994 - October 2006 * -!* Quadratic Bottom Drag by James Stephens and R. Hallberg. * -!* * -!* This file contains the subroutine that calculates various values * -!* related to the bottom boundary layer, such as the viscosity and * -!* thickness of the BBL (set_viscous_BBL). This would also be the * -!* module in which other viscous quantities that are flow-independent * -!* might be set. This information is transmitted to other modules * -!* via a vertvisc type structure. * -!* * -!* The same code is used for the two velocity components, by * -!* indirectly referencing the velocities and defining a handful of * -!* direction-specific defined variables. * -!* * -!* Macros written all in capital letters are defined in MOM_memory.h. * -!* * -!* A small fragment of the grid is shown below: * -!* * -!* j+1 x ^ x ^ x At x: q * -!* j+1 > o > o > At ^: v, frhatv, tauy * -!* j x ^ x ^ x At >: u, frhatu, taux * -!* j > o > o > At o: h * -!* j-1 x ^ x ^ x * -!* i-1 i i+1 At x & ^: * -!* i i+1 At > & o: * -!* * -!* The boundaries always run through q grid points (x). * -!* * -!********+*********+*********+*********+*********+*********+*********+** - use MOM_debugging, only : uvchksum, hchksum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr @@ -44,8 +12,9 @@ module MOM_set_visc use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_kappa_shear, only : kappa_shear_is_used -use MOM_CVMix_shear, only : CVMix_shear_is_used -use MOM_CVMix_conv, only : CVMix_conv_is_used +use MOM_cvmix_shear, only : cvmix_shear_is_used +use MOM_cvmix_conv, only : cvmix_conv_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_io, only : vardesc, var_desc use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_variables, only : thermo_var_ptrs @@ -643,7 +612,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (oldfn >= ustarsq) then cycle - else if ((oldfn + Dfn) <= ustarsq) then + elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) @@ -659,7 +628,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, CS, symmetrize) if (oldfn >= ustarsq) then cycle - else if ((oldfn + Dfn) <= ustarsq) then + elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) else Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn)/Dfn) @@ -1617,12 +1586,12 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, CS, symmetrize) do_any_shelf = .false. if (associated(forces%frac_shelf_v)) then - do I=Is,Ie + do i=is,ie if (forces%frac_shelf_v(i,J)*G%mask2dCv(i,J) == 0.0) then - do_i(I) = .false. + do_i(i) = .false. visc%tbl_thick_shelf_v(i,J) = 0.0 ; visc%kv_tbl_shelf_v(i,J) = 0.0 else - do_i(I) = .true. ; do_any_shelf = .true. + do_i(i) = .true. ; do_any_shelf = .true. endif enddo endif @@ -1791,8 +1760,10 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & do_not_log=.true.) - use_kappa_shear = .false. ; use_CVMix_shear = .false. ; - useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. ; + + use_kappa_shear = .false. ; use_CVMix_shear = .false. + useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. + if (.not.adiabatic) then use_kappa_shear = kappa_shear_is_used(param_file) use_CVMix_shear = CVMix_shear_is_used(param_file) @@ -1811,7 +1782,9 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) allocate(visc%Kd_shear(isd:ied,jsd:jed,nz+1)) ; visc%Kd_shear(:,:,:) = 0.0 allocate(visc%TKE_turb(isd:ied,jsd:jed,nz+1)) ; visc%TKE_turb(:,:,:) = 0.0 allocate(visc%Kv_shear(isd:ied,jsd:jed,nz+1)) ; visc%Kv_shear(:,:,:) = 0.0 - allocate(visc%Kv_slow(isd:ied,jsd:jed,nz+1)) ; visc%Kv_slow(:,:,:) = 0.0 + + ! MOM_bkgnd_mixing is always used, so always allocate visc%Kv_slow. GMM + allocate(visc%Kv_slow(isd:ied,jsd:jed,nz+1)) ; visc%Kv_slow(:,:,:) = 0.0 vd = var_desc("Kd_shear","m2 s-1","Shear-driven turbulent diffusivity at interfaces", & hor_grid='h', z_grid='i') @@ -1854,21 +1827,14 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) type(set_visc_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module type(ocean_OBC_type), pointer :: OBC -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) GV - The ocean's vertical grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in) diag - A structure that is used to regulate diagnostic output. -! (out) visc - A structure containing vertical viscosities and related -! fields. Allocated here. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module + + ! local variables real :: Csmag_chan_dflt, smag_const1, TKE_decay_dflt, bulk_Ri_ML_dflt real :: Kv_background real :: omega_frac_dflt integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, i, j, n - logical :: use_kappa_shear, adiabatic, differential_diffusion, use_omega + logical :: use_kappa_shear, adiabatic, use_omega + logical :: use_CVMix_ddiff, differential_diffusion, use_KPP type(OBC_segment_type), pointer :: segment ! pointer to OBC segment type ! This include declares and sets the variable "version". #include "version_variable.h" @@ -1891,8 +1857,9 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) ! Set default, read and log parameters call log_version(param_file, mdl, version, "") - CS%RiNo_mix = .false. - use_kappa_shear = .false. ; differential_diffusion = .false. !; adiabatic = .false. ! Needed? -AJA + CS%RiNo_mix = .false. ; use_CVMix_ddiff = .false. + use_kappa_shear = .false. !; adiabatic = .false. ! Needed? -AJA + differential_diffusion = .false. call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag \n"//& "law of the form c_drag*|u|*u. The velocity magnitude \n"//& @@ -1923,7 +1890,9 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) "If true, increase diffusivitives for temperature or salt \n"//& "based on double-diffusive paramaterization from MOM4/KPP.", & default=.false.) + use_CVMix_ddiff = CVMix_ddiff_is_used(param_file) endif + call get_param(param_file, mdl, "PRANDTL_TURB", visc%Prandtl_turb, & "The turbulent Prandtl number applied to shear \n"//& "instability.", units="nondim", default=1.0) @@ -2016,6 +1985,25 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) "The background kinematic viscosity in the interior. \n"//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true.) + + call get_param(param_file, mdl, "ADD_KV_SLOW", visc%add_Kv_slow, & + "If true, the background vertical viscosity in the interior \n"//& + "(i.e., tidal + background + shear + convenction) is addded \n"// & + "when computing the coupling coefficient. The purpose of this \n"// & + "flag is to be able to recover previous answers and it will likely \n"// & + "be removed in the future since this option should always be true.", & + default=.false.) + + call get_param(param_file, mdl, "USE_KPP", use_KPP, & + "If true, turns on the [CVMix] KPP scheme of Large et al., 1994,\n"// & + "to calculate diffusivities and non-local transport in the OBL.", & + do_not_log=.true., default=.false.) + + if (use_KPP .and. visc%add_Kv_slow) call MOM_error(FATAL,"set_visc_init: "//& + "When USE_KPP=True, ADD_KV_SLOW must be false. Otherwise vertical "//& + "viscosity due to slow processes will be double counted. Please set "//& + "ADD_KV_SLOW=False.") + call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & "The minimum viscosities in the bottom boundary layer.", & units="m2 s-1", default=Kv_background) @@ -2065,7 +2053,7 @@ subroutine set_visc_init(Time, G, GV, param_file, diag, visc, CS, OBC) Time, 'Rayleigh drag velocity at v points', 'm s-1') endif - if (differential_diffusion) then + if (use_CVMix_ddiff .or. differential_diffusion) then allocate(visc%Kd_extra_T(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_T = 0.0 allocate(visc%Kd_extra_S(isd:ied,jsd:jed,nz+1)) ; visc%Kd_extra_S = 0.0 endif @@ -2113,4 +2101,37 @@ subroutine set_visc_end(visc, CS) deallocate(CS) end subroutine set_visc_end +!> \namespace MOM_set_visc +!!********+*********+*********+*********+*********+*********+*********+** +!!* * +!!* By Robert Hallberg, April 1994 - October 2006 * +!!* Quadratic Bottom Drag by James Stephens and R. Hallberg. * +!!* * +!!* This file contains the subroutine that calculates various values * +!!* related to the bottom boundary layer, such as the viscosity and * +!!* thickness of the BBL (set_viscous_BBL). This would also be the * +!!* module in which other viscous quantities that are flow-independent * +!!* might be set. This information is transmitted to other modules * +!!* via a vertvisc type structure. * +!!* * +!!* The same code is used for the two velocity components, by * +!!* indirectly referencing the velocities and defining a handful of * +!!* direction-specific defined variables. * +!!* * +!!* Macros written all in capital letters are defined in MOM_memory.h. * +!!* * +!!* A small fragment of the grid is shown below: * +!!* * +!!* j+1 x ^ x ^ x At x: q * +!!* j+1 > o > o > At ^: v, frhatv, tauy * +!!* j x ^ x ^ x At >: u, frhatu, taux * +!!* j > o > o > At o: h * +!!* j-1 x ^ x ^ x * +!!* i-1 i i+1 At x & ^: * +!!* i i+1 At > & o: * +!!* * +!!* The boundaries always run through q grid points (x). * +!!* * +!!********+*********+*********+*********+*********+*********+*********+** + end module MOM_set_visc diff --git a/src/parameterizations/vertical/MOM_shortwave_abs.F90 b/src/parameterizations/vertical/MOM_shortwave_abs.F90 index 1e22ba5bf9..f0695785f8 100644 --- a/src/parameterizations/vertical/MOM_shortwave_abs.F90 +++ b/src/parameterizations/vertical/MOM_shortwave_abs.F90 @@ -365,7 +365,7 @@ subroutine sumSWoverBands(G, GV, h, opacity_band, nsw, j, dt, & ! Arguments: ! (in) G = ocean grid structure ! (in) GV = The ocean's vertical grid structure. -! (in) h = layer thickness (units of m or kg/m^2); +! (in) h = layer thickness (units of m or kg/m^2) ! units of h are referred to as H below. ! (in) opacity_band = opacity in each band of penetrating shortwave ! radiation, in m-1. The indicies are band, i, k. diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 0bb4a9bfdb..3e55557c89 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -120,29 +120,23 @@ module MOM_sponge contains +!> 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. subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, & Iresttime_i_mean, int_height_i_mean) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: int_height - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(sponge_CS), pointer :: CS + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Iresttime !< The inverse of the restoring time, in s-1. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), intent(in) :: int_height !< The interface heights to damp back toward, in m. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(sponge_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module real, dimension(SZJ_(G)), optional, intent(in) :: Iresttime_i_mean real, dimension(SZJ_(G),SZK_(G)+1), optional, intent(in) :: int_height_i_mean -! 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. -! Arguments: Iresttime - The inverse of the restoring time, in s-1. -! (in) int_height - The interface heights to damp back toward, in m. -! (in) G - The ocean's grid structure. -! (in) param_file - A structure indicating the open file to parse for -! model parameter values. -! (in/out) CS - A pointer that is set to point to the control structure -! for this module ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_sponge" ! This module's name. @@ -226,21 +220,15 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, & end subroutine initialize_sponge +!> This subroutine sets up diagnostics for the sponges. It is separate +!! from initialize_sponge because it requires fields that are not readily +!! availble where initialize_sponge is called. subroutine init_sponge_diags(Time, G, diag, CS) - type(time_type), target, intent(in) :: Time + type(time_type), target, intent(in) :: Time !< The current model time type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(diag_ctrl), target, intent(inout) :: diag - type(sponge_CS), pointer :: CS - -! This subroutine sets up diagnostics for the sponges. It is separate -! from initialize_sponge because it requires fields that are not readily -! availble where initialize_sponge is called. - -! Arguments: Time - The current model time. -! (in) G - The ocean's grid structure. -! (in) diag - A structure that is used to regulate diagnostic output. -! (in/out) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. + type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that + !! is set by a previous call to initialize_sponge. if (.not.associated(CS)) return @@ -250,25 +238,19 @@ subroutine init_sponge_diags(Time, G, diag, CS) end subroutine init_sponge_diags +!> This subroutine stores the reference profile for the variable +!! whose address is given by f_ptr. nlay is the number of layers in +!! this variable. subroutine set_up_sponge_field(sp_val, f_ptr, G, nlay, CS, sp_val_i_mean) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: sp_val - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr - integer, intent(in) :: nlay - type(sponge_CS), pointer :: CS - real, dimension(SZJ_(G),SZK_(G)), optional, intent(in) :: sp_val_i_mean -! This subroutine stores the reference profile for the variable -! whose address is given by f_ptr. nlay is the number of layers in -! this variable. - -! Arguments: sp_val - The reference profiles of the quantity being -! registered. -! (in) f_ptr - a pointer to the field which will be damped. -! (in) nlay - the number of layers in this quantity. -! (in/out) CS - A pointer to the control structure for this module that is -! set by a previous call to initialize_sponge. -! (in,opt) sp_val_i_mean - The i-mean reference value for this field with -! i-mean sponges. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: sp_val !< The reference profiles of the quantity being + !! registered. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), target, intent(in) :: f_ptr !< a pointer to the field which will be damped + integer, intent(in) :: nlay !< the number of layers in this quantity + type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that + !! is set by a previous call to initialize_sponge. + real, dimension(SZJ_(G),SZK_(G)), optional, intent(in) :: sp_val_i_mean !< The i-mean reference value for + !! this field with i-mean sponges. integer :: j, k, col character(len=256) :: mesg ! String for error messages diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index cb868d9e95..226f7c4918 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -301,7 +301,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, end select endif - else if (CS%use_CVMix_tidal) then + elseif (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Cannot set INT_TIDE_DISSIPATION to False "// & "when USE_CVMix_TIDAL is set to True.") endif @@ -315,7 +315,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Lee wave driven dissipation scheme cannot "// & "be used when CVMix tidal mixing scheme is active.") - end if + endif call get_param(param_file, mdl, "LEE_WAVE_PROFILE", tmpstr, & "LEE_WAVE_PROFILE selects the vertical profile of energy \n"//& "dissipation with LEE_WAVE_DISSIPATION. Valid values are:\n"//& @@ -346,7 +346,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Polzin scheme cannot "// & "be used when CVMix tidal mixing scheme is active.") - end if + endif call get_param(param_file, mdl, "NU_POLZIN", CS%Nu_Polzin, & "When the Polzin decay profile is used, this is a \n"//& "non-dimensional constant in the expression for the \n"//& @@ -428,7 +428,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, if (CS%use_CVMix_tidal) then call MOM_error(FATAL, "tidal_mixing_init: Tidal amplitude files are "// & "not compatible with CVMix tidal mixing. ") - end if + endif call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & "The path to the file containing the spatially varying \n"//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") @@ -459,7 +459,7 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, ! Compute the fixed part of internal tidal forcing; units are [kg s-2] here. CS%TKE_itidal(i,j) = 0.5*CS%kappa_h2_factor*GV%Rho0*& CS%kappa_itides*CS%h2(i,j)*utide*utide - enddo; enddo + enddo ; enddo endif @@ -588,8 +588,10 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale',diag%axesT1,Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', 'm') - CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model','Polzin_decay_scale_scaled',diag%axesT1,Time, & - 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme, scaled by N2_bot/N2_meanz', 'm') + CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model', & + 'Polzin_decay_scale_scaled',diag%axesT1,Time, & + 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme, '// & + 'scaled by N2_bot/N2_meanz', 'm') CS%id_N2_bot = register_diag_field('ocean_model','N2_b',diag%axesT1,Time, & 'Bottom Buoyancy frequency squared', 's-2') @@ -640,7 +642,7 @@ end function tidal_mixing_init !! tidal dissipation and to add the effect of internal-tide-driven mixing to the layer or interface !! diffusivities. subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & - N2_lay, N2_int, Kd, Kd_int, Kd_max) + N2_lay, N2_int, Kd, Kd_int, Kd_max, Kv) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) @@ -653,10 +655,12 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int real, intent(inout) :: Kd_max + real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface + !! (not layer!) in m2 s-1. if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then - call calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) + call calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd, Kv) else call add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & N2_lay, Kd, Kd_int, Kd_max) @@ -667,7 +671,7 @@ subroutine calculate_tidal_mixing(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, & !> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven !! mixing to the interface diffusivities. -subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) +subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd, Kv) integer, intent(in) :: j type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -675,6 +679,8 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) real, dimension(SZI_(G),SZK_(G)+1), intent(in) :: N2_int real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2). real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: Kd + real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface + !! (not layer!) in m2 s-1. ! local real, dimension(SZK_(G)+1) :: Kd_tidal !< tidal diffusivity [m2/s] @@ -690,7 +696,8 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) integer :: i, k, is, ie real :: dh, hcorr, Simmons_coeff - real, parameter :: rho_fw = 1000.0 ! fresh water density [kg/m^3] ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) + real, parameter :: rho_fw = 1000.0 ! fresh water density [kg/m^3] + ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) real :: h_neglect, h_neglect_edge type(tidal_mixing_diags), pointer :: dd @@ -741,11 +748,18 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) CVMix_params = CS%CVMix_glb_params, & CVMix_tidal_params_user = CS%CVMix_tidal_params) + ! Update diffusivity do k=1,G%ke Kd(i,j,k) = Kd(i,j,k) + 0.5*(Kd_tidal(k) + Kd_tidal(k+1) ) - !TODO: Kv(i,j,k) = ???????????? enddo + ! Update viscosity + if (associated(Kv)) then + do k=1,G%ke+1 + Kv(i,j,k) = Kv(i,j,k) + Kv_tidal(k) + enddo + endif + ! diagnostics if (associated(dd%Kd_itidal)) then dd%Kd_itidal(i,j,:) = Kd_tidal(:) @@ -833,11 +847,18 @@ subroutine calculate_CVMix_tidal(h, j, G, GV, CS, N2_int, Kd) CVmix_params = CS%CVMix_glb_params, & CVmix_tidal_params_user = CS%CVMix_tidal_params) + ! Update diffusivity do k=1,G%ke Kd(i,j,k) = Kd(i,j,k) + 0.5*(Kd_tidal(k) + Kd_tidal(k+1) ) - !TODO: Kv(i,j,k) = ???????????? enddo + ! Update viscosity + if (associated(Kv)) then + do k=1,G%ke+1 + Kv(i,j,k) = Kv(i,j,k) + Kv_tidal(k) + enddo + endif + ! diagnostics if (associated(dd%Kd_itidal)) then dd%Kd_itidal(i,j,:) = Kd_tidal(:) @@ -886,12 +907,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), optional, intent(inout) :: Kd_int real, intent(inout) :: Kd_max - ! This subroutine adds the effect of internal-tide-driven mixing to the layer diffusivities. - ! The mechanisms considered are (1) local dissipation of internal waves generated by the - ! barotropic flow ("itidal"), (2) local dissipation of internal waves generated by the propagating - ! low modes (rays) of the internal tide ("lowmode"), and (3) local dissipation of internal lee waves. - ! Will eventually need to add diffusivity due to other wave-breaking processes (e.g. Bottom friction, - ! Froude-number-depending breaking, PSI, etc.). + ! local real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the @@ -1173,7 +1189,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, dd%Kd_lowmode_work(i,j,k) = GV%Rho0 * TKE_lowmode_lay if (associated(dd%Fl_lowmode)) dd%Fl_lowmode(i,j,k) = TKE_lowmode_rem(i) - enddo ; enddo ; + enddo ; enddo endif ! Simmons ! Polzin: @@ -1259,7 +1275,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, dd%Kd_lowmode_work(i,j,k) = GV%Rho0 * TKE_lowmode_lay if (associated(dd%Fl_lowmode)) dd%Fl_lowmode(i,j,k) = TKE_lowmode_rem(i) - enddo ; enddo; + enddo ; enddo endif ! Polzin end subroutine add_int_tide_diffusivity @@ -1592,5 +1608,4 @@ subroutine tidal_mixing_end(CS) end subroutine tidal_mixing_end - end module MOM_tidal_mixing diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index ff14a698ed..bafbe5eb59 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2,7 +2,7 @@ module MOM_vert_friction ! This file is part of MOM6. See LICENSE.md for the license. - +use MOM_domains, only : pass_var, To_All, Omit_corners use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl use MOM_debugging, only : uvchksum, hchksum @@ -20,7 +20,7 @@ module MOM_vert_friction use MOM_variables, only : cont_diag_ptrs, accel_diag_ptrs use MOM_variables, only : ocean_internal_state use MOM_verticalGrid, only : verticalGrid_type - +use MOM_wave_interface, only : wave_parameters_CS implicit none ; private #include @@ -116,9 +116,11 @@ module MOM_vert_friction integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_Ray_u = -1, id_Ray_v = -1, id_taux_bot = -1, id_tauy_bot = -1 + integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 !>@} type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() + logical :: StokesMixing end type vertvisc_CS contains @@ -138,7 +140,7 @@ module MOM_vert_friction !! if DIRECT_STRESS is true, applied to the surface layer. subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & - taux_bot, tauy_bot) + taux_bot, tauy_bot, Waves) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, intent(inout), & @@ -155,12 +157,14 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & !! equations for diagnostics type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation terms type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure - !> Zonal bottom stress from ocean to rock in Pa - real, optional, intent(out), dimension(SZIB_(G),SZJ_(G)) :: taux_bot - !> Meridional bottom stress from ocean to rock in Pa - real, optional, intent(out), dimension(SZI_(G),SZJB_(G)) :: tauy_bot - - ! Fields from fluxes used in this subroutine: + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: taux_bot !< Zonal bottom stress from ocean to rock in Pa + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to rock in Pa + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave/Stokes information + + ! Fields from forces used in this subroutine: ! taux: Zonal wind stress in Pa. ! tauy: Meridional wind stress in Pa. @@ -195,6 +199,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & ! units of m2 s-1. logical :: do_i(SZIB_(G)) + logical :: DoStokesMixing integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz, n is = G%isc ; ie = G%iec @@ -213,20 +218,34 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & h_neglect = GV%H_subroundoff Idt = 1.0 / dt + !Check if Stokes mixing allowed if requested (present and associated) + if (CS%StokesMixing) then + DoStokesMixing=(present(Waves) .and. associated(Waves)) + if (.not.DoStokesMixing) then + call MOM_error(FATAL,"Stokes Mixing called without allocated"//& + "Waves Control Structure") + endif + else + DoStokesMixing=.false. + endif + do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo ! Update the zonal velocity component using a modification of a standard ! tridagonal solver. -!$OMP parallel do default(none) shared(G,Isq,Ieq,ADp,nz,u,CS,dt_Rho0,forces,h, & -!$OMP h_neglect,Hmix,I_Hmix,visc,dt_m_to_H, & -!$OMP Idt,taux_bot,Rho0) & -!$OMP firstprivate(Ray) & -!$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & -!$OMP b_denom_1,b1,d1,c1) + + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then ; do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq + if (G%mask2dCu(I,j) > 0) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + enddo ; enddo ; enddo ; endif + + !$OMP parallel do default(shared) firstprivate(Ray) & + !$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 - if (ASSOCIATED(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = u(I,j,k) enddo ; enddo ; endif @@ -297,11 +316,11 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & u(I,j,k) = u(I,j,k) + c1(I,k+1) * u(I,j,k+1) endif ; enddo ; enddo ! i and k loops - if (ASSOCIATED(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt enddo ; enddo ; endif - if (ASSOCIATED(visc%taux_shelf)) then ; do I=Isq,Ieq + if (associated(visc%taux_shelf)) then ; do I=Isq,Ieq visc%taux_shelf(I,j) = -Rho0*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? enddo ; endif @@ -315,17 +334,25 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & endif enddo ! end u-component j loop + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then ; do k=1,nz ; do j=G%jsc,G%jec ; do I=Isq,Ieq + if (G%mask2dCu(I,j) > 0) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + enddo ; enddo ; enddo ; endif + ! Now work on the meridional velocity component. -!$OMP parallel do default(none) shared(G,Jsq,Jeq,ADp,nz,v,CS,dt_Rho0,forces,h, & -!$OMP Hmix,I_Hmix,visc,dt_m_to_H,Idt,Rho0, & -!$OMP tauy_bot,is,ie) & -!$OMP firstprivate(Ray) & -!$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & -!$OMP b_denom_1,b1,d1,c1) + ! When mixing down Eulerian current + Stokes drift add before calling solver + if (DoStokesMixing) then ; do k=1,nz ; do j=Jsq,Jeq ; do I=Is,Ie + if (G%mask2dCv(I,j) > 0) & + v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) + enddo ; enddo ; enddo ; endif + + !$OMP parallel do default(shared) firstprivate(Ray) & + !$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 - if (ASSOCIATED(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_visc(i,J,k) = v(i,J,k) enddo ; enddo ; endif @@ -370,11 +397,11 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & v(i,J,k) = v(i,J,k) + c1(i,k+1) * v(i,J,k+1) endif ; enddo ; enddo ! i and k loops - if (ASSOCIATED(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_visc(i,J,k) = (v(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt enddo ; enddo ; endif - if (ASSOCIATED(visc%tauy_shelf)) then ; do i=is,ie + if (associated(visc%tauy_shelf)) then ; do i=is,ie visc%tauy_shelf(i,J) = -Rho0*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? enddo ; endif @@ -388,6 +415,11 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, CS, & endif enddo ! end of v-component J loop + ! When mixing down Eulerian current + Stokes drift subtract after calling solver + if (DoStokesMixing) then ; do k=1,nz ; do J=Jsq,Jeq ; do i=Is,Ie + if (G%mask2dCv(i,J) > 0) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) + enddo ; enddo ; enddo ; endif + call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) ! Here the velocities associated with open boundary conditions are applied. @@ -583,6 +615,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) ! based on harmonic mean thicknesses, in m or kg m-2. h_ml ! The mixed layer depth, in m or kg m-2. real, allocatable, dimension(:,:) :: hML_u, hML_v + real, allocatable, dimension(:,:,:) :: Kv_v, & !< Total vertical viscosity at u-points + Kv_u !< Total vertical viscosity at v-points real :: zcol(SZI_(G)) ! The height of an interface at h-points, in m or kg m-2. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior. @@ -615,6 +649,14 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) I_Hbbl(:) = 1.0 / (CS%Hbbl * GV%m_to_H + h_neglect) I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val + if (CS%id_Kv_u > 0) then + allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,G%ke)) ; Kv_u(:,:,:) = 0.0 + endif + + if (CS%id_Kv_v > 0) then + allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,G%ke)) ; Kv_v(:,:,:) = 0.0 + endif + if (CS%debug .or. (CS%id_hML_u > 0)) then allocate(hML_u(G%IsdB:G%IedB,G%jsd:G%jed)) ; hML_u(:,:) = 0.0 endif @@ -790,6 +832,13 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) ; enddo ; enddo endif + ! Diagnose total Kv at u-points + if (CS%id_Kv_u > 0) then + do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) + enddo ; enddo + endif + enddo @@ -953,6 +1002,14 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = a(i,K) ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) ; enddo ; enddo endif + + ! Diagnose total Kv at v-points + if (CS%id_Kv_v > 0) then + do k=1,nz ; do i=is,ie + if (do_i(I)) Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) + enddo ; enddo + endif + enddo ! end of v-point j loop if (CS%debug) then @@ -966,6 +1023,9 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, CS, OBC) endif ! Offer diagnostic fields for averaging. + if (CS%id_Kv_slow > 0) call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag) + if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag) + if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag) if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag) if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag) if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag) @@ -1134,6 +1194,44 @@ subroutine find_coupling_coef(a, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_m endif endif + ! add "slow" varying vertical viscosity (e.g., from background, tidal etc) + if (associated(visc%Kv_slow) .and. (visc%add_Kv_slow)) then + ! GMM/ A factor of 2 is also needed here, see comment above from BGR. + if (work_on_u) then + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_add(i,K) = Kv_add(i,K) + 1.0 * (visc%Kv_slow(i,j,k) + visc%Kv_slow(i+1,j,k)) + endif ; enddo ; enddo + if (do_OBCs) then + do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j,k) ; enddo + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i+1,j,k) ; enddo + endif + endif ; enddo + endif + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + a(i,K) = a(i,K) + Kv_add(i,K) + endif ; enddo ; enddo + else + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + Kv_add(i,K) = Kv_add(i,K) + 1.0*(visc%Kv_slow(i,j,k) + visc%Kv_slow(i,j+1,k)) + endif ; enddo ; enddo + if (do_OBCs) then + do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j,k) ; enddo + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + do K=2,nz ; Kv_add(i,K) = Kv_add(i,K) + 2. * visc%Kv_slow(i,j+1,k) ; enddo + endif + endif ; enddo + endif + do K=2,nz ; do i=is,ie ; if (do_i(i)) then + a(i,K) = a(i,K) + Kv_add(i,K) + endif ; enddo ; enddo + endif + endif + do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then ! botfn determines when a point is within the influence of the bottom ! boundary layer, going from 1 at the bottom to 0 in the interior. @@ -1342,7 +1440,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) do k=1,nz ; do I=Isq,Ieq ; if (abs(u(I,j,k)) > maxvel) then u(I,j,k) = SIGN(truncvel,u(I,j,k)) if (h(i,j,k) + h(i+1,j,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo + endif ; enddo ; enddo endif ; endif enddo ! j-loop else ! Do not report accelerations leading to large velocities. @@ -1375,9 +1473,8 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. call write_u_accel(I, j, u_old, h, ADp, CDp, dt, G, GV, CS%PointAccel_CSp, & - vel_report(I,j), -vel_report(I,j), forces%taux(I,j)*dt_Rho0, & - a=CS%a_u(:,j,:), hv=CS%h_u(:,j,:)) - endif ; enddo; enddo + vel_report(I,j), forces%taux(I,j)*dt_Rho0, a=CS%a_u, hv=CS%h_u) + endif ; enddo ; enddo endif if (len_trim(CS%v_trunc_file) > 0) then @@ -1428,7 +1525,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) do k=1,nz ; do i=is,ie ; if (abs(v(i,J,k)) > maxvel) then v(i,J,k) = SIGN(truncvel,v(i,J,k)) if (h(i,j,k) + h(i,j+1,k) > H_report) CS%ntrunc = CS%ntrunc + 1 - endif ; enddo ; enddo + endif ; enddo ; enddo endif ; endif enddo ! J-loop else ! Do not report accelerations leading to large velocities. @@ -1461,9 +1558,8 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, CS) ! Here the diagnostic reporting subroutines are called if ! unphysically large values were found. call write_v_accel(i, J, v_old, h, ADp, CDp, dt, G, GV, CS%PointAccel_CSp, & - vel_report(i,J), -vel_report(i,J), forces%tauy(i,J)*dt_Rho0, & - a=CS%a_v(:,J,:),hv=CS%h_v(:,J,:)) - endif ; enddo; enddo + vel_report(i,J), forces%tauy(i,J)*dt_Rho0, a=CS%a_v, hv=CS%h_v) + endif ; enddo ; enddo endif end subroutine vertvisc_limit_vel @@ -1532,12 +1628,12 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & "The absolute path to a file into which the accelerations \n"//& "leading to zonal velocity truncations are written. \n"//& "Undefine this for efficiency if this diagnostic is not \n"//& - "needed.", default=" ") + "needed.", default=" ", debuggingParam=.true.) call get_param(param_file, mdl, "V_TRUNC_FILE", CS%v_trunc_file, & "The absolute path to a file into which the accelerations \n"//& "leading to meridional velocity truncations are written. \n"//& "Undefine this for efficiency if this diagnostic is not \n"//& - "needed.", default=" ") + "needed.", default=" ", debuggingParam=.true.) call get_param(param_file, mdl, "HARMONIC_VISC", CS%harmonic_visc, & "If true, use the harmonic mean thicknesses for \n"//& "calculating the vertical viscosity.", default=.false.) @@ -1612,6 +1708,25 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & "The start value of the truncation CFL number used when\n"//& "ramping up CFL_TRUNC.", & units="nondim", default=0.) + call get_param(param_file, mdl, "STOKES_MIXING_COMBINED", CS%StokesMixing, & + "Flag to use Stokes drift Mixing via the Lagrangian \n"//& + " current (Eulerian plus Stokes drift). \n"//& + " Still needs work and testing, so not recommended for use.",& + Default=.false.) + !BGR 04/04/2018{ + ! StokesMixing is required for MOM6 for some Langmuir mixing parameterization. + ! The code used here has not been developed for vanishing layers or in + ! conjunction with any bottom friction. Therefore, the following line is + ! added so this functionality cannot be used without user intervention in + ! the code. This will prevent general use of this functionality until proper + ! care is given to the previously mentioned issues. Comment out the following + ! MOM_error to use, but do so at your own risk and with these points in mind. + !} + if (CS%StokesMixing) then + call MOM_error(FATAL, "Stokes mixing requires user interfention in the code.\n"//& + " Model now exiting. See MOM_vert_friction.F90 for \n"//& + " details (search 'BGR 04/04/2018' to locate comment).") + endif call get_param(param_file, mdl, "VEL_UNDERFLOW", CS%vel_underflow, & "A negligibly small velocity magnitude below which velocity \n"//& "components are set to 0. A reasonable value might be \n"//& @@ -1623,17 +1738,30 @@ subroutine vertvisc_init(MIS, Time, G, GV, param_file, diag, ADp, dirs, & ALLOC_(CS%a_v(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v(:,:,:) = 0.0 ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 + CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & + 'Slow varying vertical viscosity', 'm2 s-1') + + CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & + 'Total vertical viscosity at u-points', 'm2 s-1') + + CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & + 'Total vertical viscosity at v-points', 'm2 s-1') + CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1') + CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1') CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & 'Thickness at Zonal Velocity Points for Viscosity', thickness_units) + CS%id_h_v = register_diag_field('ocean_model', 'Hv_visc', diag%axesCvL, Time, & 'Thickness at Meridional Velocity Points for Viscosity', thickness_units) + CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', thickness_units) + CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', thickness_units) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index d306bb9e79..9c4536a013 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -178,7 +178,6 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS, & real :: e(SZK_(G)+1), e_top, e_bot, d_tr integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB - type(OBC_segment_type), pointer :: segment if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -215,7 +214,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS, & ! This adds the stripes of tracer to every layer. CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + tr_y enddo - enddo; enddo; enddo + enddo ; enddo ; enddo if (NTR > 7) then do j=js,je ; do i=is,ie @@ -276,31 +275,6 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, h, diag, OBC, CS, & deallocate(temp) endif - if (associated(OBC)) then - call query_vardesc(CS%tr_desc(1), name, caller="initialize_DOME_tracer") - if (OBC%specified_v_BCs_exist_globally) then - segment => OBC%segment(1) - allocate(segment%field(NTR)) - allocate(segment%field(1)%buffer_src(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB,nz)) -! allocate(OBC_tr1_v(G%isd:G%ied,G%jsd:G%jed,nz)) - do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%isd,segment%HI%ied - if (k < nz/2) then ; segment%field(1)%buffer_src(i,j,k) = 0.0 - else ; segment%field(1)%buffer_src(i,j,k) = 1.0 ; endif - enddo ; enddo ; enddo - call register_segment_tracer(CS%tr_desc(1), param_file, GV, & - OBC%segment(1), OBC_array=.true.) - else - ! This is not expected in the DOME example. - 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,NTR - call query_vardesc(CS%tr_desc(m), name, caller="initialize_DOME_tracer") - call register_segment_tracer(CS%tr_desc(m), param_file, GV, & - OBC%segment(1), OBC_scalar=0.0) - enddo - endif - end subroutine initialize_DOME_tracer !> This subroutine applies diapycnal diffusion and any other column @@ -311,25 +285,29 @@ end subroutine initialize_DOME_tracer !! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to - !! any possible forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to DOME_register_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to DOME_register_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the @@ -344,7 +322,7 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, do m=1,NTR do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -392,7 +370,8 @@ end subroutine DOME_tracer_surface_state !> Clean up memory allocations, if any. subroutine DOME_tracer_end(CS) - type(DOME_tracer_CS), pointer :: 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 diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 80c2cc2c3c..f867c26764 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -79,8 +79,10 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, & restart_CS) type(hor_index_type), intent(in) :: HI !This subroutine initializes the NTR tracer fields in tr(:,:,:,:) +!> This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. subroutine initialize_OCMIP2_CFC(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) @@ -420,10 +420,12 @@ end subroutine initialize_OCMIP2_CFC subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: tr - character(len=*), intent(in) :: name - real, intent(in) :: land_val, IC_val - type(OCMIP2_CFC_CS), pointer :: CS + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(out) :: tr !< The tracer concentration array + character(len=*), intent(in) :: name !< The tracer name + real, intent(in) :: land_val !< A value the tracer takes over land + real, intent(in) :: IC_val !< The initial condition value for the tracer + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. ! This subroutine initializes a tracer array. @@ -464,31 +466,29 @@ end subroutine init_tracer_CFC ! flux as a source. subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: ea !< an array to which the amount of fluid - !! entrained from the layer above during - !! this call will be added, in m or kg m-2. + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(in) :: eb !< an array to which the amount of fluid - !! entrained from the layer below during - !! this call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to any - !! possible forcing fields. Unused fields - !! have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this - !! call, in s - type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a - !! previous call to register_OCMIP2_CFC. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! CFCs are relatively simple, as they are passive tracers. with only a surface @@ -542,14 +542,14 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CFC11, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CFC12, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) @@ -701,7 +701,8 @@ subroutine OCMIP2_CFC_surface_state(state, h, G, CS) end subroutine OCMIP2_CFC_surface_state subroutine OCMIP2_CFC_end(CS) - type(OCMIP2_CFC_CS), pointer :: CS + type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_OCMIP2_CFC. ! This subroutine deallocates the memory owned by this module. ! Argument: CS - The control structure returned by a previous call to ! register_OCMIP2_CFC. diff --git a/src/tracer/MOM_OCMIP2_CO2calc.F90 b/src/tracer/MOM_OCMIP2_CO2calc.F90 index 0f3d16abd1..58b4adb380 100644 --- a/src/tracer/MOM_OCMIP2_CO2calc.F90 +++ b/src/tracer/MOM_OCMIP2_CO2calc.F90 @@ -29,9 +29,7 @@ module MOM_ocmip2_co2calc_mod !{ !------------------------------------------------------------------ ! -implicit none - -private +implicit none ; private public :: MOM_ocmip2_co2calc, CO2_dope_vector @@ -127,7 +125,7 @@ subroutine MOM_ocmip2_co2calc(dope_vec, mask, & real, dimension(dope_vec%isd:dope_vec%ied,dope_vec%jsd:dope_vec%jed), & intent(inout) :: htotal real, dimension(dope_vec%isd:dope_vec%ied,dope_vec%jsd:dope_vec%jed), & - intent(out), optional :: alpha, & + optional, intent(out) :: alpha, & pCO2surf, & co2star, & co3_ion @@ -336,7 +334,7 @@ subroutine MOM_ocmip2_co2calc(dope_vec, mask, & ! recommended (xacc of 10**-9 drops precision to 2 significant ! figures). ! - if (mask(i,j) .ne. 0.0) then !{ + if (mask(i,j) /= 0.0) then !{ htotal(i,j) = drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, & ks, kf, bt, dic_in(i,j), ft, pt_in(i,j),& sit_in(i,j), st, ta_in(i,j), & @@ -412,7 +410,7 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & bt, dic, ft, pt, sit, st, ta, x1, fl, df) call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & bt, dic, ft, pt, sit, st, ta, x2, fh, df) -if(fl .lt. 0.0) then +if (fl < 0.0) then xl=x1 xh=x2 else @@ -421,19 +419,19 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & swap=fl fl=fh fh=swap -end if +endif drtsafe=0.5*(x1+x2) dxold=abs(x2-x1) dx=dxold call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & bt, dic, ft, pt, sit, st, ta, drtsafe, f, df) do j=1,maxit !{ - if (((drtsafe-xh)*df-f)*((drtsafe-xl)*df-f) .ge. 0.0 .or. & - abs(2.0*f) .gt. abs(dxold*df)) then + if (((drtsafe-xh)*df-f)*((drtsafe-xl)*df-f) >= 0.0 .or. & + abs(2.0*f) > abs(dxold*df)) then dxold=dx dx=0.5*(xh-xl) drtsafe=xl+dx - if (xl .eq. drtsafe) then + if (xl == drtsafe) then ! write (6,*) 'Exiting drtsafe at A on iteration ', j, ', ph = ', -log10(drtsafe) return endif @@ -442,24 +440,24 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & dx=f/df temp=drtsafe drtsafe=drtsafe-dx - if (temp .eq. drtsafe) then + if (temp == drtsafe) then ! write (6,*) 'Exiting drtsafe at B on iteration ', j, ', ph = ', -log10(drtsafe) return endif - end if - if (abs(dx) .lt. xacc) then + endif + if (abs(dx) < xacc) then ! write (6,*) 'Exiting drtsafe at C on iteration ', j, ', ph = ', -log10(drtsafe) return endif call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & bt, dic, ft, pt, sit, st, ta, drtsafe, f, df) - if(f .lt. 0.0) then + if (f < 0.0) then xl=drtsafe fl=f else xh=drtsafe fh=f - end if + endif enddo !} j return diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 36e73b9ee2..7b7fe8e5a2 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -178,7 +178,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Get the tracer list call generic_tracer_get_list(CS%g_tracer_list) - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ": No tracer in the list.") ! For each tracer name get its T_prog index and get its fields @@ -205,7 +205,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -235,11 +235,11 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, !! where, and what open boundary conditions are used. type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< Pointer to the control structure for the - !! ALE sponges. - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure for diagnostics - !! in depth space. + !! ALE sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. character(len=fm_string_len), parameter :: sub_name = 'initialize_MOM_generic_tracer' logical :: OK @@ -260,13 +260,13 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia CS%diag=>diag !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list do - if(INDEX(CS%IC_file, '_NULL_') .ne. 0) then + if (INDEX(CS%IC_file, '_NULL_') /= 0) then call MOM_error(WARNING,"The name of the IC_file "//trim(CS%IC_file)//& " indicates no MOM initialization was asked for the generic tracers."//& "Bypassing the MOM initialization of ALL generic tracers!") @@ -279,7 +279,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia 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 + 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 ") @@ -293,22 +293,25 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !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) .ne. CS%tracer_land_val) then - if(tr_ptr(i,j,k) .lt. g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min + 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) .gt. g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max + !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 + enddo ; enddo ; enddo !jgj: Reset CASED to 0 below K=1 - if(trim(g_tracer_name) .eq. 'cased') then + if (trim(g_tracer_name) == 'cased') then do k=2,nk ; do j=jsc,jec ; do i=isc,iec - if(tr_ptr(i,j,k) .ne. CS%tracer_land_val) then + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then tr_ptr(i,j,k) = 0.0 endif - enddo; enddo ; enddo + 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. !This path should be deprecated if all generic tracers are required to start from specified sources. if (len_trim(CS%IC_file) > 0) then @@ -335,7 +338,8 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia endif else call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& - "check Generic Tracer IC filename "//trim(CS%IC_file)//".") + "check Generic Tracer IC filename "//trim(CS%IC_file)//& + " for tracer "//trim(g_tracer_name)) endif endif @@ -343,7 +347,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo !! end section to re-initialize generic tracers @@ -355,7 +359,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia grid_tmask(:,:,:) = 0.0 grid_kmt(:,:) = 0 do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) .gt. 0) then + if (G%mask2dT(i,j) > 0) then grid_tmask(i,j,:) = 1.0 grid_kmt(i,j) = G%ke ! Tell the code that a layer thicker than 1m is the bottom layer. endif @@ -376,7 +380,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia ! Register Z diagnostic output. !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list @@ -393,7 +397,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -401,16 +405,16 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !For each special diagnostics name get its fields !Get the diag list call generic_tracer_get_diag_list(CS%g_diag_list) - if(associated(CS%g_diag_list)) then + if (associated(CS%g_diag_list)) then g_diag=>CS%g_diag_list do - if(g_diag%Z_diag .ne. 0) & + if (g_diag%Z_diag /= 0) & call register_Z_tracer(g_diag%field_ptr, trim(g_diag%name),g_diag%longname , g_diag%units, & day, G, diag_to_Z_CSp) !traverse the linked list till hit NULL g_diag=>g_diag%next - if(.NOT. associated(g_diag)) exit + if (.NOT. associated(g_diag)) exit enddo endif @@ -433,14 +437,14 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, !! in m or kg !m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, !! in m or kg !m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< an array to which the amount of + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< an array to which the amount of !! fluid entrained from the layer !above during this !! call will be added, in m or kg !m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< an array to which the amount of + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< an array to which the amount of !! fluid entrained from the layer !below during this !! call will be added, in m or kg !m-2. type(forcing), intent(in) :: fluxes @@ -450,9 +454,9 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(optics_type), intent(in) :: optics real, optional,intent(in) :: evap_CFL_limit !< Limits how much water can be fluxed out of - !! the top layer Stored previously in diabatic CS. + !! the top layer Stored previously in diabatic CS. real, optional,intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied Stored previously in diabatic CS. + !! can be applied Stored previously in diabatic CS. ! The arguments to this subroutine are redundant in that ! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] @@ -473,7 +477,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& trim(sub_name)//": No tracer in the list.") #ifdef _USE_MOM6_DIAG @@ -493,7 +497,7 @@ 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 + 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) @@ -505,7 +509,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -517,12 +521,12 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, rho_dzt(:,:,:) = GV%H_to_kg_m2 * GV%Angstrom do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ rho_dzt(i,j,k) = GV%H_to_kg_m2 * h_old(i,j,k) - enddo; enddo ; enddo !} + enddo ; enddo ; enddo !} dzt(:,:,:) = 1.0 do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ dzt(i,j,k) = GV%H_to_m * h_old(i,j,k) - enddo; enddo ; enddo !} + enddo ; enddo ; enddo !} do j=jsc,jec ; do i=isc,iec surface_field(i,j) = tv%S(i,j,1) @@ -546,14 +550,14 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, if (g_tracer_is_prog(g_tracer)) then do k=1,nk ;do j=jsc,jec ; do i=isc,iec h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) 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 + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo endif @@ -564,14 +568,17 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - call generic_tracer_vertdiff_G(h_work, ea, eb, dt, GV%kg_m2_to_H, GV%m_to_H, 1) !Last arg is tau which is always 1 for MOM + ! Last arg is tau which is always 1 for MOM6 + call generic_tracer_vertdiff_G(h_work, ea, eb, dt, GV%kg_m2_to_H, GV%m_to_H, 1) else - call generic_tracer_vertdiff_G(h_old, ea, eb, dt, GV%kg_m2_to_H, GV%m_to_H, 1) !Last arg is tau which is always 1 for MOM + ! Last arg is tau which is always 1 for MOM6 + call generic_tracer_vertdiff_G(h_old, ea, eb, dt, GV%kg_m2_to_H, GV%m_to_H, 1) endif ! Update bottom fields after vertical processes - call generic_tracer_update_from_bottom(dt, 1, get_diag_time_end(CS%diag)) !Second arg is tau which is always 1 for MOM + ! Second arg is tau which is always 1 for MOM6 + call generic_tracer_update_from_bottom(dt, 1, get_diag_time_end(CS%diag)) !Output diagnostics via diag_manager for all generic tracers and their fluxes call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) @@ -620,7 +627,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde return endif ; endif - if(.NOT. associated(CS%g_tracer_list)) return ! No stocks. + if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. m=1 ; g_tracer=>CS%g_tracer_list do @@ -639,7 +646,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next m = m+1 enddo @@ -651,21 +658,28 @@ end function MOM_generic_tracer_stock !> This subroutine find the global min and max of either of all !! available tracer concentrations, or of a tracer that is being !! requested specifically, returning the number of tracers it has gone through. - function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax , G, CS, names, units) + function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, & + xgmax, ygmax, zgmax , G, CS, names, units) use mpp_utilities_mod, only: mpp_array_global_min_max - integer, intent(in) :: ind_start - logical, dimension(:), intent(out) :: got_minmax - real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: xgmin, ygmin, zgmin, xgmax, ygmax, zgmax - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - 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. - integer :: MOM_generic_tracer_min_max !< Return value, the - !! number of tracers done here. + integer, intent(in) :: ind_start + logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg + !! times concentration units. + real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg + !! times concentration units. + real, dimension(:), intent(out) :: xgmin !< The x-position of the global minimum + real, dimension(:), intent(out) :: ygmin !< The y-position of the global minimum + real, dimension(:), intent(out) :: zgmin !< The z-position of the global minimum + real, dimension(:), intent(out) :: xgmax !< The x-position of the global maximum + real, dimension(:), intent(out) :: ygmax !< The y-position of the global maximum + real, dimension(:), intent(out) :: zgmax !< The z-position of the global maximum + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + 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. + integer :: MOM_generic_tracer_min_max !< Return value, the + !! number of tracers done here. ! Local variables type(g_tracer_type), pointer :: g_tracer, g_tracer_next @@ -684,7 +698,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg MOM_generic_tracer_min_max = 0 if (.not.associated(CS)) return - if(.NOT. associated(CS%g_tracer_list)) return ! No stocks. + if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. call g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,grid_tmask=grid_tmask) @@ -709,14 +723,15 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg call mpp_array_global_min_max(tr_ptr, grid_tmask,isd,jsd,isc,iec,jsc,jec,nk , gmin(m), gmax(m), & - G%geoLonT,G%geoLatT,geo_z,xgmin(m), ygmin(m), zgmin(m), xgmax(m), ygmax(m), zgmax(m)) + G%geoLonT,G%geoLatT,geo_z,xgmin(m), ygmin(m), zgmin(m), & + xgmax(m), ygmax(m), zgmax(m)) got_minmax(m) = .true. !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next m = m+1 enddo @@ -763,7 +778,7 @@ subroutine MOM_generic_tracer_surface_state(state, h, G, CS) tau=1,sosga=sosga,model_time=get_diag_time_end(CS%diag)) !Output diagnostics via diag_manager for all tracers in this module -! if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& +! if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ! "No tracer in the list.") ! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld @@ -775,7 +790,7 @@ end subroutine MOM_generic_tracer_surface_state !ALL PE subroutine on Ocean! Due to otpm design the fluxes should be initialized like this on ALL PE's! subroutine MOM_generic_flux_init(verbosity) - integer, intent(in), optional :: verbosity !< A 0-9 integer indicating a level of 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 @@ -789,7 +804,7 @@ subroutine MOM_generic_flux_init(verbosity) endif call generic_tracer_get_list(g_tracer_list) - if(.NOT. associated(g_tracer_list)) then + if (.NOT. associated(g_tracer_list)) then call mpp_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") return endif @@ -801,7 +816,7 @@ subroutine MOM_generic_flux_init(verbosity) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 7b421a7ca8..65679fe2a6 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -51,13 +51,17 @@ module MOM_neutral_diffusion ! Positions of neutral surfaces in both the u, v directions real, allocatable, dimension(:,:,:) :: uPoL ! Non-dimensional position with left layer uKoL-1, u-point real, allocatable, dimension(:,:,:) :: uPoR ! Non-dimensional position with right layer uKoR-1, u-point - integer, allocatable, dimension(:,:,:) :: uKoL ! Index of left interface corresponding to neutral surface, u-point - integer, allocatable, dimension(:,:,:) :: uKoR ! Index of right interface corresponding to neutral surface, u-point + integer, allocatable, dimension(:,:,:) :: uKoL ! Index of left interface corresponding to neutral surface, + ! at a u-point + integer, allocatable, dimension(:,:,:) :: uKoR ! Index of right interface corresponding to neutral surface, + ! at a u-point real, allocatable, dimension(:,:,:) :: uHeff ! Effective thickness at u-point (H units) real, allocatable, dimension(:,:,:) :: vPoL ! Non-dimensional position with left layer uKoL-1, v-point real, allocatable, dimension(:,:,:) :: vPoR ! Non-dimensional position with right layer uKoR-1, v-point - integer, allocatable, dimension(:,:,:) :: vKoL ! Index of left interface corresponding to neutral surface, v-point - integer, allocatable, dimension(:,:,:) :: vKoR ! Index of right interface corresponding to neutral surface, v-point + integer, allocatable, dimension(:,:,:) :: vKoL ! Index of left interface corresponding to neutral surface, + ! at a v-point + integer, allocatable, dimension(:,:,:) :: vKoR ! Index of right interface corresponding to neutral surface, + ! at a v-point real, allocatable, dimension(:,:,:) :: vHeff ! Effective thickness at v-point (H units) ! Coefficients of polynomial reconstructions for temperature and salinity real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients for temperature @@ -74,7 +78,8 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:,:,:) :: dRdT_i ! dRho/dT (kg/m3/degC) at top edge real, allocatable, dimension(:,:,:,:) :: dRdS_i ! dRho/dS (kg/m3/ppt) at top edge integer, allocatable, dimension(:,:) :: ns ! Number of interfacs in a column - logical, allocatable, dimension(:,:,:) :: stable_cell ! True if the cell is stably stratified wrt to the next cell + logical, allocatable, dimension(:,:,:) :: stable_cell ! True if the cell is stably stratified wrt + ! to the next cell type(diag_ctrl), pointer :: diag ! structure to regulate output integer :: id_uhEff_2d = -1 @@ -372,9 +377,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) endif enddo ; enddo - ! Continuous reconstructions calculate hEff as the difference between the pressures of the neutral surfaces which - ! need to be reconverted to thickness units. The discontinuous version calculates hEff from the fraction of the - ! nondimensional fraction of the layer occupied by the + ! Continuous reconstructions calculate hEff as the difference between the pressures of the + ! neutral surfaces which need to be reconverted to thickness units. The discontinuous version + ! calculates hEff from the fraction of the nondimensional fraction of the layer occupied by + ! the... (Please finish this thought. -RWH) if (CS%continuous_reconstruction) then 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 @@ -388,14 +394,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, h, T, S, CS) hEff_sum(:,:) = 0. do k = 1,CS%nsurf-1 ; do j=G%jsc,G%jec ; do i=G%isc-1,G%iec hEff_sum(i,j) = hEff_sum(i,j) + CS%uhEff(i,j,k) - enddo ; enddo; enddo + enddo ; enddo ; enddo call post_data(CS%id_uhEff_2d, hEff_sum, CS%diag) endif if (CS%id_vhEff_2d>0) then hEff_sum(:,:) = 0. do k = 1,CS%nsurf-1 ; do j=G%jsc-1,G%jec ; do i=G%isc,G%iec hEff_sum(i,j) = hEff_sum(i,j) + CS%vhEff(i,j,k) - enddo ; enddo; enddo + enddo ; enddo ; enddo call post_data(CS%id_vhEff_2d, hEff_sum, CS%diag) endif @@ -408,7 +414,8 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (H units) real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points (m^2) real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at u-points (m^2) - real, intent(in) :: dt !< Tracer time step * I_numitts (I_numitts in tracer_hordiff) + real, intent(in) :: dt !< Tracer time step * I_numitts + !! (I_numitts in tracer_hordiff) type(tracer_registry_type), pointer :: Reg !< Tracer registry type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure @@ -438,7 +445,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) tracer => Reg%Tr(m) ! for diagnostics - if(tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 .or. & + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 .or. & tracer%id_dfx_2d > 0 .or. tracer%id_dfy_2d > 0) then Idt = 1.0/dt tendency(:,:,:) = 0.0 @@ -476,7 +483,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dT(i,j)>0.) then dTracer(:) = 0. - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 k = CS%uKoL(I,j,ks) dTracer(k) = dTracer(k) + Coef_x(I,j) * uFlx(I,j,ks) k = CS%uKoR(I-1,j,ks) @@ -491,7 +498,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) enddo - if(tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then do k = 1, GV%ke tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt enddo @@ -502,11 +509,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. - if(tracer%id_dfx_2d > 0) then + if (tracer%id_dfx_2d > 0) then do j = G%jsc,G%jec ; do I = G%isc-1,G%iec trans_x_2d(I,j) = 0. if (G%mask2dCu(I,j)>0.) then - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) enddo trans_x_2d(I,j) = trans_x_2d(I,j) * Idt @@ -517,11 +524,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. - if(tracer%id_dfy_2d > 0) then + if (tracer%id_dfy_2d > 0) then do J = G%jsc-1,G%jec ; do i = G%isc,G%iec trans_y_2d(i,J) = 0. if (G%mask2dCv(i,J)>0.) then - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) enddo trans_y_2d(i,J) = trans_y_2d(i,J) * Idt @@ -531,12 +538,12 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) endif ! post tendency of tracer content - if(tracer%id_dfxy_cont > 0) then + if (tracer%id_dfxy_cont > 0) then call post_data(tracer%id_dfxy_cont, tendency(:,:,:), CS%diag) endif ! post depth summed tendency for tracer content - if(tracer%id_dfxy_cont_2d > 0) then + if (tracer%id_dfxy_cont_2d > 0) then tendency_2d(:,:) = 0. do j = G%jsc,G%jec ; do i = G%isc,G%iec do k = 1, GV%ke @@ -549,7 +556,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! post tendency of tracer concentration; this step must be ! done after posting tracer content tendency, since we alter ! the tendency array. - if(tracer%id_dfxy_conc > 0) then + if (tracer%id_dfxy_conc > 0) then do k = 1, GV%ke ; do j = G%jsc,G%jec ; do i = G%isc,G%iec tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + GV%H_subroundoff ) enddo ; enddo ; enddo @@ -799,8 +806,8 @@ end function fvlsq_slope !> Returns positions within left/right columns of combined interfaces using continuous reconstructions of T/S -subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdSl, Pr, Tr, Sr, dRdTr, dRdSr, PoL, & - PoR, KoL, KoR, hEff) +subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdSl, Pr, Tr, Sr, & + dRdTr, dRdSr, PoL, PoR, KoL, KoR, hEff) integer, intent(in) :: nk !< Number of levels real, dimension(nk+1), intent(in) :: Pl !< Left-column interface pressure (Pa) real, dimension(nk+1), intent(in) :: Tl !< Left-column interface potential temperature (degC) @@ -812,8 +819,10 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS real, dimension(nk+1), intent(in) :: Sr !< Right-column interface salinity (ppt) real, dimension(nk+1), intent(in) :: dRdTr !< Left-column dRho/dT (kg/m3/degC) real, dimension(nk+1), intent(in) :: dRdSr !< Left-column dRho/dS (kg/m3/ppt) - real, dimension(2*nk+2), intent(inout) :: PoL !< Fractional position of neutral surface within layer KoL of left column - real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within layer KoR of right column + real, dimension(2*nk+2), intent(inout) :: PoL !< Fractional position of neutral surface within + !! layer KoL of left column + real, dimension(2*nk+2), intent(inout) :: PoR !< Fractional position of neutral surface within + !! layer KoR of right column integer, dimension(2*nk+2), intent(inout) :: KoL !< Index of first left interface above neutral surface integer, dimension(2*nk+2), intent(inout) :: KoR !< Index of first right interface above neutral surface real, dimension(2*nk+1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces (Pa) @@ -979,10 +988,10 @@ end subroutine find_neutral_surface_positions_continuous !> Higher order version of find_neutral_surface_positions. Returns positions within left/right columns !! of combined interfaces using intracell reconstructions of T/S -subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, & - Pres_l, hcol_l, Tl, Sl, dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & +subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol_l, Tl, Sl, & + dRdT_l, dRdS_l, stable_l, Pres_r, hcol_r, Tr, Sr, dRdT_r, dRdS_r, stable_r, & PoL, PoR, KoL, KoR, hEff, ppoly_T_l, ppoly_S_l, ppoly_T_r, ppoly_S_r) - type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + type(neutral_diffusion_CS), intent(inout) :: CS !< Neutral diffusion control structure integer, intent(in) :: nk !< Number of levels integer, intent(in) :: ns !< Number of neutral surfaces real, dimension(nk+1), intent(in) :: Pres_l !< Left-column interface pressure (Pa) @@ -1006,10 +1015,14 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, integer, dimension(4*nk), intent(inout) :: KoL !< Index of first left interface above neutral surface integer, dimension(4*nk), intent(inout) :: KoR !< Index of first right interface above neutral surface real, dimension(4*nk-1), intent(inout) :: hEff !< Effective thickness between two neutral surfaces (Pa) - real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction - real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction - real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction - real, dimension(nk,CS%deg+1), optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction + real, dimension(nk,CS%deg+1), & + optional, intent(in) :: ppoly_T_l !< Left-column coefficients of T reconstruction + real, dimension(nk,CS%deg+1), & + optional, intent(in) :: ppoly_S_l !< Left-column coefficients of S reconstruction + real, dimension(nk,CS%deg+1), & + optional, intent(in) :: ppoly_T_r !< Right-column coefficients of T reconstruction + real, dimension(nk,CS%deg+1), & + optional, intent(in) :: ppoly_S_r !< Right-column coefficients of S reconstruction ! Local variables integer :: k_surface ! Index of neutral surface @@ -1032,8 +1045,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. ! Check to make sure that polynomial reconstructions were passed if refine_pos defined) - if(CS%refine_position) then - if (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. present(ppoly_T_r) .and. present(ppoly_S_r) )) & + if (CS%refine_position) then + if (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. & + present(ppoly_T_r) .and. present(ppoly_S_r) ) ) & call MOM_error(FATAL, "fine_neutral_surface_positions_discontinuous: refine_pos is requested, but " //& "polynomial coefficients not available for T and S") endif @@ -1063,10 +1077,11 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, ! Loop over each neutral surface, working from top to bottom neutral_surfaces: do k_surface = 1, ns ! Potential density difference, rho(kr) - rho(kl) - dRho = 0.5 * & - ( ( dRdT_r(kl_right,ki_right) + dRdT_l(kl_left,ki_left) ) * ( Tr(kl_right,ki_right) - Tl(kl_left,ki_left) ) & - + ( dRdS_r(kl_right,ki_right) + dRdS_l(kl_left,ki_left) ) * ( Sr(kl_right,ki_right) - Sl(kl_left,ki_left) ) ) - if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho, & + dRho = 0.5 * ( ( dRdT_r(kl_right,ki_right) + dRdT_l(kl_left,ki_left) ) * & + ( Tr(kl_right,ki_right) - Tl(kl_left,ki_left) ) & + + ( dRdS_r(kl_right,ki_right) + dRdS_l(kl_left,ki_left) ) * & + ( Sr(kl_right,ki_right) - Sl(kl_left,ki_left) ) ) + if (CS%debug) write(*,'(A,I2,A,E12.4,A,I2,A,I2,A,I2,A,I2)') "k_surface=",k_surface," dRho=",dRho, & "kl_left=",kl_left, " ki_left=",ki_left," kl_right=",kl_right, " ki_right=",ki_right ! Which column has the lighter surface for the current indexes, kr and kl if (.not. reached_bottom) then @@ -1077,7 +1092,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, searching_right_column = .true. searching_left_column = .false. else ! dRho == 0. - if ( ( kl_left == kl_left_0) .and. ( kl_right == kl_right_0 ) .and. (ki_left + ki_right == 2) ) then ! Still at surface + if ( ( kl_left == kl_left_0) .and. ( kl_right == kl_right_0 ) .and. & + (ki_left + ki_right == 2) ) then ! Still at surface searching_left_column = .true. searching_right_column = .false. else ! Not the surface so we simply change direction @@ -1103,7 +1119,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, call drho_at_pos(CS%ndiff_aux_CS, T_other, S_other, dRdT_other, dRdS_other, Pres_l(kl_left), & Pres_l(kl_left+1), ppoly_T_l(kl_left,:), ppoly_S_l(kl_left,:), lastP_left, dRhoTop) else - dRhoTop = calc_drho(Tl(kl_left,1), Sl(kl_left,1), dRdT_l(kl_left,1), dRdS_l(kl_left,1), T_other, S_other, & + dRhoTop = calc_drho(Tl(kl_left,1), Sl(kl_left,1), dRdT_l(kl_left,1), dRdS_l(kl_left,1), T_other, S_other, & dRdT_other, dRdS_other) endif ! Potential density difference, rho(kl) - rho(kl_right,ki_right) (will be positive) @@ -1123,8 +1139,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, KoR(k_surface) = kl_right ! Set position within the searched column - call search_other_column(dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), lastP_left, lastK_left, kl_left, & - kl_left_0, ki_left, top_connected_l, bot_connected_l, PoL(k_surface), KoL(k_surface), search_layer) + call search_other_column(dRhoTop, dRhoBot, Pres_l(kl_left), Pres_l(kl_left+1), & + lastP_left, lastK_left, kl_left, kl_left_0, ki_left, & + top_connected_l, bot_connected_l, PoL(k_surface), KoL(k_surface), search_layer) if ( CS%refine_position .and. search_layer ) then min_bound = 0. @@ -1137,7 +1154,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, endif if (PoL(k_surface) == 0.) top_connected_l(KoL(k_surface)) = .true. if (PoL(k_surface) == 1.) bot_connected_l(KoL(k_surface)) = .true. - call increment_interface(nk, kl_right, ki_right, stable_r, reached_bottom, searching_right_column, searching_left_column) + call increment_interface(nk, kl_right, ki_right, stable_r, reached_bottom, & + searching_right_column, searching_left_column) elseif (searching_right_column) then if (CS%ref_pres>=0.) then @@ -1189,7 +1207,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, endif if (PoR(k_surface) == 0.) top_connected_r(KoR(k_surface)) = .true. if (PoR(k_surface) == 1.) bot_connected_r(KoR(k_surface)) = .true. - call increment_interface(nk, kl_left, ki_left, stable_l, reached_bottom, searching_left_column, searching_right_column) + call increment_interface(nk, kl_left, ki_left, stable_l, reached_bottom, & + searching_left_column, searching_right_column) else stop 'Else what?' @@ -1197,8 +1216,8 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, lastK_left = KoL(k_surface) ; lastP_left = PoL(k_surface) lastK_right = KoR(k_surface) ; lastP_right = PoR(k_surface) - if (CS%debug) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), " KoR:", & - KoR(k_surface), " PoR:", PoR(k_surface) + if (CS%debug) write(*,'(A,I3,A,ES16.6,A,I2,A,ES16.6)') "KoL:", KoL(k_surface), " PoL:", PoL(k_surface), & + " KoR:", KoR(k_surface), " PoR:", PoR(k_surface) ! Effective thickness if (k_surface>1) then ! This is useful as a check to make sure that positions are monotonically increasing @@ -1300,7 +1319,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h0. - type(remapping_CS), optional, intent(in) :: remap_CS + type(remapping_CS), optional, intent(in) :: remap_CS !< Remapping control structure used + !! to create sublayers real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value calculations !! in the same units as h0. @@ -1364,7 +1384,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K dT_bottom = T_right_bottom - T_left_bottom dT_ave = 0.5 * ( dT_top + dT_bottom ) dT_layer = T_right_layer - T_left_layer - if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0. ) then + if (signum(1.,dT_top) * signum(1.,dT_bottom) <= 0. .or. signum(1.,dT_ave) * signum(1.,dT_layer) <= 0.) then dT_ave = 0. else dT_ave = dT_layer @@ -1372,10 +1392,12 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K Flx(k_sublayer) = dT_ave * hEff(k_sublayer) else ! Discontinuous reconstruction ! Calculate tracer values on left and right side of the neutral surface - call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, ppoly_r_coeffs_l, & - T_left_top, T_left_bottom, T_left_sub, T_left_top_int, T_left_bot_int, T_left_layer) - call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoR, PiR, Tr, Tid_r, deg, iMethod, ppoly_r_coeffs_r, & - T_right_top, T_right_bottom, T_right_sub, T_right_top_int, T_right_bot_int, T_right_layer) + call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, & + ppoly_r_coeffs_l, T_left_top, T_left_bottom, T_left_sub, & + T_left_top_int, T_left_bot_int, T_left_layer) + call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoR, PiR, Tr, Tid_r, deg, iMethod, & + ppoly_r_coeffs_r, T_right_top, T_right_bottom, T_right_sub, & + T_right_top_int, T_right_bot_int, T_right_layer) dT_top = T_right_top - T_left_top dT_bottom = T_right_bottom - T_left_bottom @@ -1427,7 +1449,7 @@ subroutine neutral_surface_T_eval(nk, ns, k_sub, Ks, Ps, T_mean, T_int, deg, iMe ks_top = k_sub ks_bot = k_sub + 1 - if ( Ks(ks_top) .ne. Ks(ks_bot) ) then + if ( Ks(ks_top) /= Ks(ks_bot) ) then call MOM_error(FATAL, "Neutral surfaces span more than one layer") endif kl = Ks(k_sub) @@ -1482,7 +1504,7 @@ end subroutine ppm_left_right_edge_values !> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. logical function neutral_diffusion_unit_tests(verbose) - logical, intent(in) :: verbose + logical, intent(in) :: verbose !< If true, write results to stdout neutral_diffusion_unit_tests = .false. .or. & ndiff_unit_tests_continuous(verbose) .or. ndiff_unit_tests_discontinuous(verbose) @@ -1492,7 +1514,7 @@ end function neutral_diffusion_unit_tests !> Returns true if unit tests of neutral_diffusion functions fail. Otherwise returns false. logical function ndiff_unit_tests_continuous(verbose) - logical, intent(in) :: verbose !< It true, write results to stdout + 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 @@ -1769,9 +1791,9 @@ logical function ndiff_unit_tests_discontinuous(verbose) integer, dimension(ns) :: KoL, KoR real, dimension(ns) :: PoL, PoR real, dimension(ns-1) :: hEff, Flx - type(neutral_diffusion_CS) :: CS - type(EOS_type), pointer :: EOS ! Structure for linear equation of state - type(remapping_CS), pointer :: remap_CS ! Remapping control structure (PLM) + type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure + type(EOS_type), pointer :: EOS !< Structure for linear equation of state + type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: poly_T_l, poly_T_r, poly_S, poly_slope ! Linear reconstruction for T real, dimension(nk,2) :: dRdT, dRdS logical, dimension(nk) :: stable_l, stable_r @@ -1829,7 +1851,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pR (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column slightly cooler') - Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) ; + Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) @@ -1933,7 +1955,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) allocate(EOS) call EOS_manual_init(EOS, form_of_EOS = EOS_LINEAR, dRho_dT = -1., dRho_dS = 2.) ! Unit tests for refine_nondim_position - ALLOCATE(CS%ndiff_aux_CS) + allocate(CS%ndiff_aux_CS) call set_ndiff_aux_params(CS%ndiff_aux_CS, deg = 1, max_iter = 10, drho_tol = 0., xtol = 0., EOS = EOS) ! Tests using Newton's method ndiff_unit_tests_discontinuous = ndiff_unit_tests_discontinuous .or. (test_rnp(0.5,refine_nondim_position( & @@ -2048,9 +2070,11 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) if (test_ifndp) stdunit = 0 ! 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)') 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15),x,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))') 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue + write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15))') & + 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2079,10 +2103,12 @@ 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)') 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!' + write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15,x,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)') 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) + write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15)') & + 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) endif enddo endif @@ -2122,7 +2148,8 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title) end function test_data1di -!> Returns true if output of find_neutral_surface_positions() does not match correct values, and conditionally writes results to stream +!> Returns true if output of find_neutral_surface_positions() does not match correct values, +!! and conditionally writes results to stream logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, pR0, hEff0, title) logical, intent(in) :: verbose !< If true, write results to stdout integer, intent(in) :: ns !< Number of surfaces @@ -2196,21 +2223,21 @@ end function compare_nsp_row !> Compares output position from refine_nondim_position with an expected value logical function test_rnp(expected_pos, test_pos, title) - real, intent(in) :: expected_pos - real, intent(in) :: test_pos - character(len=*), intent(in) :: title + real, intent(in) :: expected_pos !< The expected position + real, intent(in) :: test_pos !< The position returned by the code + character(len=*), intent(in) :: title !< A label for this test ! Local variables integer :: stdunit = 6 ! Output to standard error test_rnp = expected_pos /= test_pos if (test_rnp) then write(stdunit,'(A, f20.16, " .neq. ", f20.16, " <-- WRONG")') title, expected_pos, test_pos else - write(stdunit,'(A, f20.16, " .eq. ", f20.16)') title, expected_pos, test_pos + write(stdunit,'(A, f20.16, " == ", f20.16)') title, expected_pos, test_pos endif end function test_rnp !> Deallocates neutral_diffusion control structure subroutine neutral_diffusion_end(CS) - type(neutral_diffusion_CS), pointer :: CS + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure if (associated(CS)) deallocate(CS) diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index 09ed0c0e58..2cc91606ff 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -174,7 +174,7 @@ subroutine drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppol real, dimension(CS%nterm), intent(in) :: ppoly_T !< Coefficients of T reconstruction real, dimension(CS%nterm), intent(in) :: ppoly_S !< Coefficients of S reconstruciton real, intent(in) :: x0 !< Nondimensional position to evaluate - real, intent(out) :: delta_rho + real, intent(out) :: delta_rho !< The density difference from a reference value real, optional, intent(out) :: P_out !< Pressure at point x0 real, optional, intent(out) :: T_out !< Temperature at point x0 real, optional, intent(out) :: S_out !< Salinity at point x0 @@ -328,8 +328,10 @@ real function interpolate_for_nondim_position(dRhoNeg, Pneg, dRhoPos, Ppos) else ! dRhoPos - dRhoNeg < 0 interpolate_for_nondim_position = 0.5 endif - if ( interpolate_for_nondim_position < 0. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg' - if ( interpolate_for_nondim_position > 1. ) stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' + if ( interpolate_for_nondim_position < 0. ) & + stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint < Pneg' + if ( interpolate_for_nondim_position > 1. ) & + stop 'interpolate_for_nondim_position: Houston, we have a problem! Pint > Ppos' end function interpolate_for_nondim_position !> Use root-finding methods to find where dRho = 0, based on the equation of state and the polynomial @@ -339,8 +341,8 @@ end function interpolate_for_nondim_position !! to see if it it diverges outside the interval. In that case (or in the case that second derivatives are not !! available), Brent's method is used following the implementation found at !! https://people.sc.fsu.edu/~jburkardt/f_src/brent/brent.f90 -real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, drho_top, & - drho_bot, min_bound) +real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, & + ppoly_T, ppoly_S, drho_top, drho_bot, min_bound) type(ndiff_aux_CS_type), intent(in) :: CS !< Control structure with parameters for this module real, intent(in) :: T_ref !< Temperature of the neutral surface at the searched from interface real, intent(in) :: S_ref !< Salinity of the neutral surface at the searched from interface @@ -463,7 +465,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to ! For the logic to find neutral surfaces to work properly, the function needs to converge to zero ! or a small negative value - if( (fb <= 0.) .and. (fb >= -CS%drho_tol) ) then + if ((fb <= 0.) .and. (fb >= -CS%drho_tol)) then refine_nondim_position = b exit endif @@ -505,7 +507,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to fa = fb fb = fc fc = fa - end if + endif tol = 2. * machep * abs ( sb ) + CS%xtol m = 0.5 * ( c - sb ) if ( abs ( m ) <= tol .or. fb == 0. ) then @@ -524,12 +526,12 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to r = fb / fc p = s0 * ( 2. * m * q * ( q - r ) - ( sb - sa ) * ( r - 1. ) ) q = ( q - 1. ) * ( r - 1. ) * ( s0 - 1. ) - end if + endif if ( 0. < p ) then q = - q else p = - p - end if + endif s0 = e e = d if ( 2. * p < 3. * m * q - abs ( tol * q ) .and. & @@ -538,17 +540,17 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to else e = m d = e - end if - end if + endif + endif sa = sb fa = fb if ( tol < abs ( d ) ) then sb = sb + d - else if ( 0. < m ) then + elseif ( 0. < m ) then sb = sb + tol else sb = sb - tol - end if + endif call drho_at_pos(CS, T_ref, S_ref, alpha_ref, beta_ref, P_top, P_bot, ppoly_T, ppoly_S, & sb, fb) if ( ( 0. < fb .and. 0. < fc ) .or. & @@ -557,7 +559,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to fc = fa e = sb - sa d = e - end if + endif enddo ! Modified from original to ensure that the minimum is found fa = ABS(fa) ; fb = ABS(fb) ; fc = ABS(fc) diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 3ee727f430..45f01686c5 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -22,7 +22,7 @@ module MOM_offline_aux use MOM_diag_mediator, only : post_data use MOM_forcing_type, only : forcing -implicit none +implicit none ; private public update_offline_from_files public update_offline_from_arrays @@ -252,7 +252,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) else h2d(i,k) = GV%H_subroundoff endif - enddo; enddo; + enddo ; enddo ! Distribute flux. Note min/max is intended to make sure that the mass transport ! does not deplete a cell @@ -320,7 +320,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) else h2d(j,k) = GV%H_subroundoff endif - enddo; enddo; + enddo ; enddo ! Distribute flux evenly throughout a column do j=js-1,je @@ -578,16 +578,16 @@ subroutine offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) call diurnal_solar(G%geoLatT(i,j)*rad, G%geoLonT(i,j)*rad, Time_start, cosz=cosz_dt, & fracday=fracday_dt, rrsun=rrsun_dt, dt_time=dt_here) - call daily_mean_solar (G%geoLatT(i,j)*rad, time_since_ae, cosz_day, fracday_day, rrsun_day) + call daily_mean_solar(G%geoLatT(i,j)*rad, time_since_ae, cosz_day, fracday_day, rrsun_day) diurnal_factor = cosz_dt*fracday_dt*rrsun_dt / & max(1e-30, cosz_day*fracday_day*rrsun_day) i2 = i+i_off ; j2 = j+j_off fluxes%sw(i2,j2) = fluxes%sw(i2,j2) * diurnal_factor fluxes%sw_vis_dir(i2,j2) = fluxes%sw_vis_dir(i2,j2) * diurnal_factor - fluxes%sw_vis_dif (i2,j2) = fluxes%sw_vis_dif (i2,j2) * diurnal_factor + fluxes%sw_vis_dif(i2,j2) = fluxes%sw_vis_dif(i2,j2) * diurnal_factor fluxes%sw_nir_dir(i2,j2) = fluxes%sw_nir_dir(i2,j2) * diurnal_factor - fluxes%sw_nir_dif (i2,j2) = fluxes%sw_nir_dif (i2,j2) * diurnal_factor + fluxes%sw_nir_dif(i2,j2) = fluxes%sw_nir_dif(i2,j2) * diurnal_factor enddo ; enddo end subroutine offline_add_diurnal_sw @@ -598,33 +598,40 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ uhtr, vhtr, temp_mean, salt_mean, mld, Kd, fluxes, ridx_sum, ridx_snap, read_mld, read_sw, & read_ts_uvh, do_ale_in) - type(ocean_grid_type), pointer, intent(inout) :: G !< Horizontal grid type - type(verticalGrid_type), pointer, intent(in ) :: GV !< Vertical grid type - integer, intent(in ) :: nk_input !< Number of levels in input file - character(len=*), intent(in ) :: mean_file !< Name of file with averages fields - character(len=*), intent(in ) :: sum_file !< Name of file with summed fields - character(len=*), intent(in ) :: snap_file !< Name of file with snapshot fields - character(len=*), intent(in ) :: surf_file !< Name of file with surface fields - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhtr !< Zonal mass fluxes - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhtr !< Meridional mass fluxes - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h_end !< End of timestep layer thickness - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: temp_mean !< Averaged temperature - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: salt_mean !< Averaged salinity - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: mld !< Averaged mixed layer depth - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1),intent(inout) :: Kd !< Averaged mixed layer depth - type(forcing), intent(inout) :: fluxes !< Fields with surface fluxes - integer, intent(in ) :: ridx_sum !< Read index for sum, mean, and surf files - integer, intent(in ) :: ridx_snap !< Read index for snapshot file - logical, intent(in ) :: read_mld !< True if reading in MLD - logical, intent(in ) :: read_sw !< True if reading in radiative fluxes - logical, intent(in ) :: read_ts_uvh !< True if reading in uh, vh, and h - logical, optional, intent(in ) :: do_ale_in !< True if using ALE algorithms + type(ocean_grid_type), intent(inout) :: G !< Horizontal grid type + type(verticalGrid_type), intent(in ) :: GV !< Vertical grid type + integer, intent(in ) :: nk_input !< Number of levels in input file + character(len=*), intent(in ) :: mean_file !< Name of file with averages fields + character(len=*), intent(in ) :: sum_file !< Name of file with summed fields + character(len=*), intent(in ) :: snap_file !< Name of file with snapshot fields + character(len=*), intent(in ) :: surf_file !< Name of file with surface fields + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: uhtr !< Zonal mass fluxes + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(inout) :: vhtr !< Meridional mass fluxes + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: h_end !< End of timestep layer thickness + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: temp_mean !< Averaged temperature + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(inout) :: salt_mean !< Averaged salinity + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: mld !< Averaged mixed layer depth + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1), & + intent(inout) :: Kd !< Diapycnal diffusivities at interfaces + type(forcing), intent(inout) :: fluxes !< Fields with surface fluxes + integer, intent(in ) :: ridx_sum !< Read index for sum, mean, and surf files + integer, intent(in ) :: ridx_snap !< Read index for snapshot file + logical, intent(in ) :: read_mld !< True if reading in MLD + logical, intent(in ) :: read_sw !< True if reading in radiative fluxes + logical, intent(in ) :: read_ts_uvh !< True if reading in uh, vh, and h + logical, optional, intent(in ) :: do_ale_in !< True if using ALE algorithms logical :: do_ale integer :: i, j, k, is, ie, js, je, nz real :: Initer_vert - do_ale = .false.; + do_ale = .false. if (present(do_ale_in) ) do_ale = do_ale_in is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -661,11 +668,11 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ ! This block makes sure that the fluxes control structure, which may not be used in the solo_driver, ! contains netMassIn and netMassOut which is necessary for the applyTracerBoundaryFluxesInOut routine if (do_ale) then - if (.not. ASSOCIATED(fluxes%netMassOut)) then + if (.not. associated(fluxes%netMassOut)) then allocate(fluxes%netMassOut(G%isd:G%ied,G%jsd:G%jed)) fluxes%netMassOut(:,:) = 0.0 endif - if (.not. ASSOCIATED(fluxes%netMassIn)) then + if (.not. associated(fluxes%netMassIn)) then allocate(fluxes%netMassIn(G%isd:G%ied,G%jsd:G%jed)) fluxes%netMassIn(:,:) = 0.0 endif @@ -700,17 +707,17 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ call MOM_read_data(mean_file,'sw_nir',fluxes%sw_nir_dir, G%Domain, & timelevel=ridx_sum) fluxes%sw_vis_dir(:,:) = fluxes%sw_vis_dir(:,:)*0.5 - fluxes%sw_vis_dif (:,:) = fluxes%sw_vis_dir + fluxes%sw_vis_dif(:,:) = fluxes%sw_vis_dir fluxes%sw_nir_dir(:,:) = fluxes%sw_nir_dir(:,:)*0.5 - fluxes%sw_nir_dif (:,:) = fluxes%sw_nir_dir + fluxes%sw_nir_dif(:,:) = fluxes%sw_nir_dir fluxes%sw = fluxes%sw_vis_dir + fluxes%sw_vis_dif + fluxes%sw_nir_dir + fluxes%sw_nir_dif do j=js,je ; do i=is,ie if (G%mask2dT(i,j)<1.0) then fluxes%sw(i,j) = 0.0 fluxes%sw_vis_dir(i,j) = 0.0 fluxes%sw_nir_dir(i,j) = 0.0 - fluxes%sw_vis_dif (i,j) = 0.0 - fluxes%sw_nir_dif (i,j) = 0.0 + fluxes%sw_vis_dif(i,j) = 0.0 + fluxes%sw_nir_dif(i,j) = 0.0 endif enddo ; enddo call pass_var(fluxes%sw,G%Domain) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index bd173a80c9..a821219cd5 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -299,7 +299,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo - if(CS%debug) then + if (CS%debug) then call hchksum(h_vol,"h_vol before advect",G%HI) call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI) write(debug_msg, '(A,I4.4)') 'Before advect ', iter @@ -607,7 +607,7 @@ real function remaining_transport_sum(CS, uhtr, vhtr) if (ABS(vhtr(i,J,k))>vh_neglect) then remaining_transport_sum = remaining_transport_sum + ABS(vhtr(i,J,k)) endif - enddo; enddo; enddo + enddo ; enddo ; enddo call sum_across_PEs(remaining_transport_sum) end function remaining_transport_sum @@ -802,7 +802,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type real, intent(in) :: time_interval !< Offline transport time interval - type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM + type(offline_transport_CS), pointer :: CS !< Control structure for offline module real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: h_pre !< layer thicknesses before advection real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: eatr !< Entrainment from layer above real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)), intent(inout) :: ebtr !< Entrainment from layer below @@ -852,15 +852,15 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 eatr_sub(i,j,k) = eatr(i,j,k) ebtr_sub(i,j,k) = ebtr(i,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-1,je+1 ; do i=is-2,ie+1 uhtr_sub(I,j,k) = uhtr(I,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-2,je+1 ; do i=is-1,ie+1 vhtr_sub(i,J,k) = vhtr(i,J,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo ! Calculate 3d mass transports to be used in this iteration @@ -881,7 +881,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) do k = 1, nz ; do i = is-1, ie+1 ; do j=js-1, je+1 h_vol(i,j,k) = h_pre(i,j,k)*G%areaT(i,j) - enddo; enddo; enddo + enddo ; enddo ; enddo call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, & CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=30, x_first_in=x_before_y) @@ -898,7 +898,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, call update_h_horizontal_flux(G, GV, uhtr_sub, vhtr_sub, h_pre, h_new) do k = 1, nz ; do i = is-1, ie+1 ; do j=js-1, je+1 h_vol(i,j,k) = h_pre(i,j,k)*G%areaT(i,j) - enddo; enddo; enddo + enddo ; enddo ; enddo call advect_tracer(h_pre, uhtr_sub, vhtr_sub, CS%OBC, dt_iter, G, GV, & CS%tracer_adv_CSp, CS%tracer_Reg, h_vol, max_iter_in=30, x_first_in=x_before_y) @@ -922,15 +922,15 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, do k = 1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 eatr(i,j,k) = eatr(i,j,k) - eatr_sub(i,j,k) ebtr(i,j,k) = ebtr(i,j,k) - ebtr_sub(i,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-1,je+1 ; do i=is-2,ie+1 uhtr(I,j,k) = uhtr(I,j,k) - uhtr_sub(I,j,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo do k = 1, nz ; do j=js-2,je+1 ; do i=is-1,ie+1 vhtr(i,J,k) = vhtr(i,J,k) - vhtr_sub(i,J,k) - enddo; enddo ; enddo + enddo ; enddo ; enddo call pass_var(eatr,G%Domain) call pass_var(ebtr,G%Domain) @@ -946,7 +946,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, sum_v = sum_v + abs(vhtr(i,J-1,k))+abs(vhtr(I,J,k)) sum_abs_fluxes = sum_abs_fluxes + abs(eatr(i,j,k)) + abs(ebtr(i,j,k)) + abs(uhtr(I-1,j,k)) + & abs(uhtr(I,j,k)) + abs(vhtr(i,J-1,k)) + abs(vhtr(i,J,k)) - enddo; enddo; enddo + enddo ; enddo ; enddo call sum_across_PEs(sum_abs_fluxes) print *, "Remaining u-flux, v-flux:", sum_u, sum_v @@ -958,7 +958,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, CS, h_pre, ! Switch order of Strang split every iteration z_first = .not. z_first x_before_y = .not. x_before_y - end do + enddo end subroutine offline_advection_layer @@ -1025,26 +1025,26 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) if (CS%G%mask2dT(i,j)<1.0) then CS%h_end(i,j,k) = CS%GV%Angstrom endif - enddo; enddo ; enddo + enddo ; enddo ; enddo do k=1,nz+1 ; do j=js,je ; do i=is,ie CS%Kd(i,j,k) = max(0.0, CS%Kd(i,j,k)) if (CS%Kd_max>0.) then CS%Kd(i,j,k) = MIN(CS%Kd_max, CS%Kd(i,j,k)) endif - enddo ; enddo ; enddo ; + enddo ; enddo ; enddo do k=1,nz ; do J=js-1,je ; do i=is,ie if (CS%G%mask2dCv(i,J)<1.0) then CS%vhtr(i,J,k) = 0.0 endif - enddo; enddo ; enddo + enddo ; enddo ; enddo do k=1,nz ; do j=js,je ; do I=is-1,ie if (CS%G%mask2dCu(I,j)<1.0) then CS%uhtr(I,j,k) = 0.0 endif - enddo; enddo ; enddo + enddo ; enddo ; enddo if (CS%debug) then call uvchksum("[uv]htr_sub after update_offline_fields", CS%uhtr, CS%vhtr, CS%G%HI) @@ -1061,9 +1061,9 @@ end subroutine update_offline_fields !> Initialize additional diagnostics required for offline tracer transport subroutine register_diags_offline_transport(Time, diag, CS) - type(offline_transport_CS), pointer :: CS !< control structure for MOM - type(time_type), intent(in) :: Time !< current model time - type(diag_ctrl) :: diag + type(offline_transport_CS), pointer :: CS !< Control structure for offline module + type(time_type), intent(in) :: Time !< current model time + type(diag_ctrl), intent(in) :: diag ! U-cell fields CS%id_uhr = register_diag_field('ocean_model', 'uhr', diag%axesCuL, Time, & @@ -1148,19 +1148,19 @@ end subroutine post_offline_convergence_diags !> Extracts members of the offline main control structure. All arguments are optional except !! the control structure itself -subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, dt_offline, dt_offline_vertical, & - skip_diffusion) - type(offline_transport_CS), target, intent(in ) :: CS !< Offline control structure +subroutine extract_offline_main(CS, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & + dt_offline, dt_offline_vertical, skip_diffusion) + type(offline_transport_CS), target, intent(in ) :: CS !< Offline control structure ! Returned optional arguments - real, dimension(:,:,:), pointer, optional, intent( out) :: uhtr - real, dimension(:,:,:), pointer, optional, intent( out) :: vhtr - real, dimension(:,:,:), pointer, optional, intent( out) :: eatr - real, dimension(:,:,:), pointer, optional, intent( out) :: ebtr - real, dimension(:,:,:), pointer, optional, intent( out) :: h_end - integer, pointer, optional, intent( out) :: accumulated_time - integer, optional, intent( out) :: dt_offline - integer, optional, intent( out) :: dt_offline_vertical - logical, optional, intent( out) :: skip_diffusion + real, dimension(:,:,:), optional, pointer :: uhtr !< Remaining zonal mass transport + real, dimension(:,:,:), optional, pointer :: vhtr !< Remaining meridional mass transport + real, dimension(:,:,:), optional, pointer :: eatr + real, dimension(:,:,:), optional, pointer :: ebtr + real, dimension(:,:,:), optional, pointer :: h_end + integer, optional, pointer :: accumulated_time + integer, optional, intent( out) :: dt_offline + integer, optional, intent( out) :: dt_offline_vertical + logical, optional, intent( out) :: skip_diffusion ! Pointers to 3d members if (present(uhtr)) uhtr => CS%uhtr @@ -1183,7 +1183,7 @@ end subroutine extract_offline_main !! are optional except for the CS itself subroutine insert_offline_main(CS, ALE_CSp, diabatic_CSp, diag, OBC, tracer_adv_CSp, & tracer_flow_CSp, tracer_Reg, tv, G, GV, x_before_y, debug) - type(offline_transport_CS), intent(inout) :: CS + type(offline_transport_CS), intent(inout) :: CS !< Offline control structure ! Inserted optional arguments type(ALE_CS), target, optional, intent(in ) :: ALE_CSp type(diabatic_CS), target, optional, intent(in ) :: diabatic_CSp @@ -1193,8 +1193,8 @@ subroutine insert_offline_main(CS, ALE_CSp, diabatic_CSp, diag, OBC, tracer_adv_ type(tracer_flow_control_CS), target, optional, intent(in ) :: tracer_flow_CSp type(tracer_registry_type), target, optional, intent(in ) :: tracer_Reg type(thermo_var_ptrs), target, optional, intent(in ) :: tv - type(ocean_grid_type), target, optional, intent(in ) :: G - type(verticalGrid_type), target, optional, intent(in ) :: GV + type(ocean_grid_type), target, optional, intent(in ) :: G !< ocean grid structure + type(verticalGrid_type), target, optional, intent(in ) :: GV !< ocean vertical grid structure logical, optional, intent(in ) :: x_before_y logical, optional, intent(in ) :: debug @@ -1218,11 +1218,11 @@ end subroutine insert_offline_main ! run time parameters from MOM_input subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV) - type(param_file_type), intent(in) :: param_file - type(offline_transport_CS), pointer, intent(inout) :: CS - type(diabatic_CS), pointer, intent(in) :: diabatic_CSp - type(ocean_grid_type), pointer, intent(in) :: G - type(verticalGrid_type), pointer, intent(in) :: GV + type(param_file_type), intent(in) :: param_file + type(offline_transport_CS), pointer :: CS !< Offline control structure + type(diabatic_CS), intent(in) :: diabatic_CSp + type(ocean_grid_type), target, intent(in) :: G !< ocean grid structure + type(verticalGrid_type), target, intent(in) :: GV !< ocean vertical grid structure character(len=40) :: mdl = "offline_transport" character(len=20) :: redistribute_method @@ -1387,7 +1387,7 @@ end subroutine offline_transport_init !> Coordinates the allocation and reading in all time levels of uh, vh, hend, temp, and salt from files. Used !! when read_all_ts_uvh subroutine read_all_input(CS) - type(offline_transport_CS), pointer, intent(inout) :: CS + type(offline_transport_CS), intent(inout) :: CS !< Control structure for offline module integer :: is, ie, js, je, isd, ied, jsd, jed, nz, t, ntime integer :: IsdB, IedB, JsdB, JedB @@ -1427,7 +1427,7 @@ end subroutine read_all_input !> Deallocates (if necessary) arrays within the offline control structure subroutine offline_transport_end(CS) - type(offline_transport_CS), pointer, intent(inout) :: CS + type(offline_transport_CS), pointer :: CS !< Control structure for offline module ! Explicitly allocate all allocatable arrays deallocate(CS%uhtr) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 9a86d25c9c..df244cd8a4 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -319,7 +319,7 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) - status = NF90_OPEN(filename, NF90_NOWRITE, ncid); + status = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(WARNING,mdl//" Difficulties opening "//trim(filename)//& " - "//trim(NF90_STRERROR(status))) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 9293940109..4d2bcd70f6 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -15,6 +15,7 @@ module MOM_tracer_advect use MOM_grid, only : ocean_grid_type 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_open_boundary, only : OBC_segment_type use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -46,21 +47,29 @@ module MOM_tracer_advect !! monotonic, conservative, weakly diffusive scheme. subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & h_prev_opt, max_iter_in, x_first_in, uhr_out, vhr_out, h_out) - type(ocean_grid_type), intent(inout) :: G !< ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_end !< layer thickness after advection (m or kg m-2) - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: uhtr !< accumulated volume/mass flux through zonal face (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: vhtr !< accumulated volume/mass flux through merid face (m3 or kg) - type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used - real, intent(in) :: dt !< time increment (seconds) - type(tracer_advect_CS), pointer :: CS !< control structure for module - type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional :: h_prev_opt !< layer thickness before advection (m or kg m-2) - integer, optional :: max_iter_in - logical, optional :: x_first_in - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), optional, intent(out) :: uhr_out !< accumulated volume/mass flux through zonal face (m3 or kg) - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), optional, intent(out) :: vhr_out !< accumulated volume/mass flux through merid face (m3 or kg) - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), optional :: h_out !< layer thickness before advection (m or kg m-2) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_end !< layer thickness after advection (m or kg m-2) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + intent(in) :: uhtr !< accumulated volume/mass flux through zonal face (m3 or kg) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + intent(in) :: vhtr !< accumulated volume/mass flux through merid face (m3 or kg) + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + real, intent(in) :: dt !< time increment (seconds) + type(tracer_advect_CS), pointer :: CS !< control structure for module + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(in) :: h_prev_opt !< layer thickness before advection (m or kg m-2) + integer, optional, intent(in) :: max_iter_in !< The maximum number of iterations + logical, optional, intent(in) :: x_first_in !< If present, indicate whether to update + !! first in the x- or y-direction. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: uhr_out !< accumulated volume/mass flux through zonal face (m3 or kg) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & + optional, intent(out) :: vhr_out !< accumulated volume/mass flux through merid face (m3 or kg) + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + optional, intent(out) :: h_out !< layer thickness before advection (m or kg m-2) type(tracer_type) :: Tr(MAX_FIELDS_) ! The array of registered tracers real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & @@ -112,8 +121,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 - if(present(max_iter_in)) max_iter = max_iter_in - if(present(x_first_in)) x_first = x_first_in + if (present(max_iter_in)) max_iter = max_iter_in + if (present(x_first_in)) x_first = x_first_in call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_uhr_vhr_t_hprev, uhr, vhr, G%Domain) call create_group_pass(CS%pass_uhr_vhr_t_hprev, hprev, G%Domain) @@ -153,7 +162,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & enddo ; enddo else do i=is,ie ; do j=js,je - hprev(i,j,k) = h_prev_opt(i,j,k); + hprev(i,j,k) = h_prev_opt(i,j,k) enddo ; enddo endif enddo @@ -300,9 +309,9 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & enddo ! Iterations loop - if(present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:) - if(present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:) - if(present(h_out)) h_out(:,:,:) = hprev(:,:,:) + if (present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:) + if (present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:) + if (present(h_out)) h_out(:,:,:) = hprev(:,:,:) call cpu_clock_end(id_clock_advect) @@ -315,15 +324,26 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & is, ie, js, je, k, G, GV, 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 - type(tracer_type), dimension(ntr), intent(inout) :: Tr - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhr - real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: uh_neglect - type(ocean_OBC_type), pointer :: OBC - logical, dimension(SZJ_(G),SZK_(G)), intent(inout) :: domore_u - real, intent(in) :: Idt - integer, intent(in) :: ntr, is, ie, js, je,k - logical, intent(in) :: usePPM, useHuynh + type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev !< cell volume at the end of previous + !! tracer change, in H m2 (m3 or kg) + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: uhr !< accumulated volume/mass flux through + !! the zonal face, in H m2 (m3 or kg) + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: uh_neglect !< A tiny zonal mass flux that can + !! be neglected, in H m2 (m3 or kg) + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + logical, dimension(SZJ_(G),SZK_(G)), 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, in 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 + integer, intent(in) :: je !< The ending tracer j-index to work on + integer, intent(in) :: k !< The k-level to work on + logical, intent(in) :: usePPM !< If true, use PPM instead of PLM + logical, intent(in) :: useHuynh !< If true, use the Huynh scheme + !! for PPM interface values real, dimension(SZI_(G),ntr) :: & slope_x ! The concentration slope per grid point in units of @@ -349,6 +369,10 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & logical :: do_any_i 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() + integer :: ishift, idir + real :: dt ! the inverse of Idt, needed for time-stepping of tracer reservoirs logical :: usePLMslope usePLMslope = .not. (usePPM .and. useHuynh) @@ -358,6 +382,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & min_h = 0.1*GV%Angstrom h_neglect = GV%H_subroundoff + dt=1.0/Idt ! do I=is-1,ie ; ts2(I) = 0.0 ; enddo do I=is-1,ie ; CFL(I) = 0.0 ; enddo @@ -501,59 +526,76 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo ; enddo endif ! usePPM - if (associated(OBC)) then ; if (OBC%OBC_pe) then ; if (OBC%specified_u_BCs_exist_globally) then - do n=1,OBC%number_of_segments - if (.not. OBC%segment(n)%specified) cycle - if (.not. associated(OBC%segment(n)%tr_Reg)) cycle - if (OBC%segment(n)%is_E_or_W) then - I = OBC%segment(n)%HI%IsdB - if (j >= OBC%segment(n)%HI%jsd .and. j<= OBC%segment(n)%HI%jed) then - I = OBC%segment(n)%HI%IsdB - ! Tracer fluxes are set to prescribed values only for inflows from masked areas. - if ((uhr(I,j,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & - (uhr(I,j,k) < 0.0) .and. (G%mask2dT(i+1,j) < 0.5)) then - uhh(I) = uhr(I,j,k) - do m=1,ntr - if (associated(OBC%segment(n)%tr_Reg%Tr(m)%t)) then - flux_x(I,m) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%t(I,j,k) - else ; flux_x(I,m) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif - enddo + if (associated(OBC)) then ; if (OBC%OBC_pe) then + if (OBC%specified_u_BCs_exist_globally) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%specified) cycle + if (.not. associated(segment%tr_Reg)) cycle + if (segment%is_E_or_W) then + if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then + I = segment%HI%IsdB + ! Tracer fluxes are set to prescribed values only for inflows from masked areas. + ! Now changing to simply fixed inflows. + if ((uhr(I,j,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_W) .or. & + (uhr(I,j,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_E)) then + uhh(I) = uhr(I,j,k) + ! should the reservoir evolve for this case Kate ?? - Nope + do m=1,ntr + if (associated(segment%tr_Reg%Tr(m)%tres)) then + flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else ; flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + enddo + endif endif endif - endif - enddo - endif - if (OBC%open_u_BCs_exist_globally) then - do n=1,OBC%number_of_segments - if (OBC%segment(n)%specified) cycle - if (.not. associated(OBC%segment(n)%tr_Reg)) cycle - if (OBC%segment(n)%is_E_or_W) then - I = OBC%segment(n)%HI%IsdB - if (j >= OBC%segment(n)%HI%jsd .and. j<= OBC%segment(n)%HI%jed) then - uhh(I) = uhr(I,j,k) + enddo + endif + + if (OBC%open_u_BCs_exist_globally) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + I = segment%HI%IsdB + if (segment%is_E_or_W .and. (j >= segment%HI%jsd .and. j<= segment%HI%jed)) then + if (segment%specified) cycle + if (.not. associated(segment%tr_Reg)) cycle + ishift=0 ! ishift+I corresponds to the nearest interior tracer cell index + idir=1 ! idir switches the sign of the flow so that positive is into the reservoir + if (segment%direction == OBC_DIRECTION_W) then + ishift=1 + idir=-1 + endif + ! update the reservoir tracer concentration implicitly + ! using Backward-Euler timestep do m=1,ntr - if (OBC%segment(n)%direction == OBC_DIRECTION_E) then - if (uhh(I) > 0.0) then - flux_x(I,m) = uhh(I)*Tr(m)%t(i,j,k) - else - if (associated(OBC%segment(n)%tr_Reg%Tr(m)%t)) then - flux_x(I,m) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%t(I,j,k) - else ; flux_x(I,m) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif - endif - else ! West - if (uhh(I) < 0.0) then - flux_x(I,m) = uhh(I)*Tr(m)%t(i+1,j,k) - else - if (associated(OBC%segment(n)%tr_Reg%Tr(m)%t)) then - flux_x(I,m) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%t(I,j,k) - else ; flux_x(I,m) = uhh(I)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif - endif + if (associated(segment%tr_Reg%Tr(m)%tres)) then + uhh(I)=uhr(I,j,k) + u_L_in=max(idir*uhh(I)*segment%Tr_InvLscale3_in,0.) + u_L_out=min(idir*uhh(I)*segment%Tr_InvLscale3_out,0.) + fac1=1.0+dt*(u_L_in-u_L_out) + segment%tr_Reg%Tr(m)%tres(I,j,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & + dt*(u_L_in*Tr(m)%t(I+ishift,j,k) - & + u_L_out*segment%tr_Reg%Tr(m)%t(I,j,k))) +! if (j == 10 .and. segment%direction==OBC_DIRECTION_E .and. m==2 .and. k == 1) & +! print *,'tres=',segment%tr_Reg%Tr(m)%tres(I,j,k),& +! segment%tr_Reg%Tr(m)%t(I,j,k), fac1 endif enddo + + ! Tracer fluxes are set to prescribed values only for inflows from masked areas. + if ((uhr(I,j,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & + (uhr(I,j,k) < 0.0) .and. (G%mask2dT(i+1,j) < 0.5)) then + uhh(I) = uhr(I,j,k) + do m=1,ntr + if (associated(segment%tr_Reg%Tr(m)%tres)) then + flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else; flux_x(I,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + enddo + endif endif - endif - enddo - endif ; endif ; endif + enddo + endif + endif ; endif ! Calculate new tracer concentration in each cell after accounting ! for the i-direction fluxes. @@ -613,15 +655,26 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & is, ie, js, je, k, G, GV, 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 - type(tracer_type), dimension(ntr), intent(inout) :: Tr - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhr - real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vh_neglect - type(ocean_OBC_type), pointer :: OBC - logical, dimension(SZJB_(G),SZK_(G)), intent(inout) :: domore_v - real, intent(in) :: Idt - integer, intent(in) :: ntr, is, ie, js, je,k - logical, intent(in) :: usePPM, useHuynh + type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: hprev !< cell volume at the end of previous + !! tracer change, in H m2 (m3 or kg) + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: vhr !< accumulated volume/mass flux through + !! the meridional face, in H m2 (m3 or kg) + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vh_neglect !< A tiny meridional mass flux that can + !! be neglected, in H m2 (m3 or kg) + type(ocean_OBC_type), pointer :: OBC !< specifies whether, where, and what OBCs are used + logical, dimension(SZJB_(G),SZK_(G)), 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, in 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 + integer, intent(in) :: je !< The ending tracer j-index to work on + integer, intent(in) :: k !< The k-level to work on + logical, intent(in) :: usePPM !< If true, use PPM instead of PLM + logical, intent(in) :: useHuynh !< If true, use the Huynh scheme + !! for PPM interface values real, dimension(SZI_(G),ntr,SZJ_(G)) :: & slope_y ! The concentration slope per grid point in units of @@ -648,6 +701,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & logical :: do_any_i 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 + integer :: jshift, jdir + real :: dt ! The inverse of Idt, needed for segment reservoir time-stepping + type(OBC_segment_type), pointer :: segment=>NULL() logical :: usePLMslope usePLMslope = .not. (usePPM .and. useHuynh) @@ -657,7 +714,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & min_h = 0.1*GV%Angstrom h_neglect = GV%H_subroundoff - + dt=1.0/Idt !do i=is,ie ; ts2(i) = 0.0 ; enddo ! We conditionally perform work on tracer points: calculating the PLM slope, @@ -810,60 +867,76 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & enddo ; enddo endif ! usePPM - if (associated(OBC)) then ; if (OBC%OBC_pe) then ; if (OBC%specified_v_BCs_exist_globally) then - do n=1,OBC%number_of_segments - if (.not. OBC%segment(n)%specified) cycle - if (.not. associated(OBC%segment(n)%tr_Reg)) cycle - if (OBC%segment(n)%is_N_or_S) then - if (J >= OBC%segment(n)%HI%JsdB .and. J<= OBC%segment(n)%HI%JedB) then - do i = OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied + if (associated(OBC)) then ; if (OBC%OBC_pe) then + if (OBC%specified_v_BCs_exist_globally) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%specified) cycle + if (.not. associated(segment%tr_Reg)) cycle + if (OBC%segment(n)%is_N_or_S) then + if (J >= segment%HI%JsdB .and. J<= segment%HI%JedB) then + do i=segment%HI%isd,segment%HI%ied + ! Tracer fluxes are set to prescribed values only for inflows from masked areas. + ! Now changing to simply fixed inflows. + if ((vhr(i,J,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_S) .or. & + (vhr(i,J,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_N)) then + vhh(i,J) = vhr(i,J,k) + do m=1,ntr + if (associated(segment%tr_Reg%Tr(m)%t)) then + flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + enddo + endif + enddo + endif + endif + enddo + endif + + + if (OBC%open_v_BCs_exist_globally) then + do n=1,OBC%number_of_segments + segment=>OBC%segment(n) + if (segment%specified) cycle + if (.not. associated(segment%tr_Reg)) cycle + if (segment%is_N_or_S .and. & + (J >= segment%HI%JsdB .and. J<= segment%HI%JedB)) then + jshift=0 + jdir=1 + if (segment%direction == OBC_DIRECTION_S) then + jshift=1 + jdir=-1 + endif + do i=segment%HI%isd,segment%HI%ied + ! update the reservoir tracer concentration implicitly + ! using Backward-Euler timestep + do m=1,ntr + if (associated(segment%tr_Reg%Tr(m)%tres)) then + vhh(i,J)=vhr(i,J,k) + v_L_in=max(jdir*vhh(i,J)*segment%Tr_InvLscale3_in,0.) + v_L_out=min(jdir*vhh(i,J)*segment%Tr_InvLscale3_out,0.) + fac1=1.0+dt*(v_L_in-v_L_out) + segment%tr_Reg%Tr(m)%tres(i,J,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(i,J,k) + & + dt*v_L_in*Tr(m)%t(i,j+jshift,k) - & + dt*v_L_out*segment%tr_Reg%Tr(m)%t(i,j,k)) + endif + enddo ! Tracer fluxes are set to prescribed values only for inflows from masked areas. if ((vhr(i,J,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & (vhr(i,J,k) < 0.0) .and. (G%mask2dT(i,j+1) < 0.5)) then vhh(i,J) = vhr(i,J,k) do m=1,ntr - if (associated(OBC%segment(n)%tr_Reg%Tr(m)%t)) then - flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%t(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + if (associated(segment%tr_Reg%Tr(m)%t)) then + flux_y(i,m,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,m,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif enddo endif - endif - enddo - endif - if (OBC%open_v_BCs_exist_globally) then - do n=1,OBC%number_of_segments - if (OBC%segment(n)%specified) cycle - if (.not. associated(OBC%segment(n)%tr_Reg)) cycle - if (OBC%segment(n)%is_N_or_S) then - if (J >= OBC%segment(n)%HI%JsdB .and. J<= OBC%segment(n)%HI%JedB) then - do i = OBC%segment(n)%HI%isd,OBC%segment(n)%HI%ied - vhh(i,J) = vhr(i,J,k) - do m=1,ntr - if (OBC%segment(n)%direction == OBC_DIRECTION_N) then - if (vhh(i,J) > 0.0) then - flux_y(i,m,J) = vhh(i,J)*Tr(m)%t(i,j,k) - else - if (associated(OBC%segment(n)%tr_Reg%Tr(m)%t)) then - flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%t(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif - endif - else ! South - if (vhh(i,J) < 0.0) then - flux_y(i,m,J) = vhh(i,J)*Tr(m)%t(i,j,k) - else - if (associated(OBC%segment(n)%tr_Reg%Tr(m)%t)) then - flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%t(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif - endif - endif - enddo - enddo - endif - endif - enddo - endif ; endif ; endif + enddo + endif + endif; endif + else ! not domore_v. do i=is,ie ; vhh(i,J) = 0.0 ; enddo do m=1,ntr ; do i=is,ie ; flux_y(i,m,J) = 0.0 ; enddo ; enddo @@ -976,7 +1049,7 @@ end subroutine tracer_advect_init !> Close the tracer advection module subroutine tracer_advect_end(CS) - type(tracer_advect_CS), pointer :: CS + type(tracer_advect_CS), pointer :: CS !< module control structure if (associated(CS)) deallocate(CS) diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 02f44e44dd..c8ce7700db 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -15,50 +15,56 @@ module MOM_tracer_diabatic #include public tracer_vertdiff public applyTracerBoundaryFluxesInOut + +contains + !> This subroutine solves a tridiagonal equation for the final tracer !! concentrations after the dual-entrainments, and possibly sinking or surface !! and bottom sources, are applied. The sinking is implemented with an !! fully implicit upwind advection scheme. - -contains - subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & sfc_flux, btm_flux, btm_reservoir, sink_rate, convert_flux_in) - 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 !< layer thickness before entrainment (m or kg m-2) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< amount of fluid entrained from the layer above (units of h_work) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< amount of fluid entrained from the layer below (units of h_work) - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: tr !< tracer concentration (in concentration units CU) - real, intent(in) :: dt !< amount of time covered by this call (seconds) - real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: sfc_flux !< surface flux of the tracer (in CU * kg m-2 s-1) - real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: btm_flux !< The (negative upward) bottom flux of the tracer, - !! in units of (CU * kg m-2 s-1) - real, dimension(SZI_(G),SZJ_(G)), optional,intent(inout) :: btm_reservoir !< amount of tracer in a bottom reservoir (units of CU kg m-2; formerly CU m) - real, optional,intent(in) :: sink_rate !< rate at which the tracer sinks, in m s-1 - logical, optional,intent(in) :: convert_flux_in !< True if the specified sfc_flux needs to be integrated in time - - real :: sink_dist ! The distance the tracer sinks in a time step, in m or kg m-2. + 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 !< layer thickness before entrainment (m or kg m-2) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: ea !< amount of fluid entrained from the layer + !! above (units of h_work) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: eb !< amount of fluid entrained from the layer + !! below (units of h_work) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: tr !< tracer concentration (in concentration units CU) + real, intent(in) :: dt !< amount of time covered by this call (seconds) + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: sfc_flux !< surface flux of the tracer in units + !! of (CU * kg m-2 s-1) + real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: btm_flux !< The (negative upward) bottom flux of the + !! tracer, in units of (CU * kg m-2 s-1) + real, dimension(SZI_(G),SZJ_(G)), optional,intent(inout) :: btm_reservoir !< amount of tracer in a bottom reservoir + !! (units of CU kg m-2; formerly CU m) + real, optional,intent(in) :: sink_rate !< rate at which the tracer sinks, in m s-1 + logical, optional,intent(in) :: convert_flux_in !< True if the specified sfc_flux needs + !! to be integrated in time + + ! local variables + real :: sink_dist !< The distance the tracer sinks in a time step, in m or kg m-2. real, dimension(SZI_(G),SZJ_(G)) :: & - sfc_src, & ! The time-integrated surface source of the tracer, in - ! units of m or kg m-2 times a concentration. - btm_src ! The time-integrated bottom source of the tracer, in - ! units of m or kg m-2 times a concentration. + sfc_src, & !< The time-integrated surface source of the tracer, in + !! units of m or kg m-2 times a concentration. + btm_src !< The time-integrated bottom source of the tracer, in + !! units of m or kg m-2 times a concentration. real, dimension(SZI_(G)) :: & - b1, & ! b1 is used by the tridiagonal solver, in m-1 or m2 kg-1. - d1 ! d1=1-c1 is used by the tridiagonal solver, nondimensional. - real :: c1(SZI_(G),SZK_(GV)) ! c1 is used by the tridiagonal solver, ND. - real :: h_minus_dsink(SZI_(G),SZK_(GV)) ! The layer thickness minus the - ! difference in sinking rates across the layer, in m or kg m-2. - ! By construction, 0 <= h_minus_dsink < h_work. - real :: sink(SZI_(G),SZK_(GV)+1) ! The tracer's sinking distances at the - ! interfaces, limited to prevent characteristics from - ! crossing within a single timestep, in m or kg m-2. - real :: b_denom_1 ! The first term in the denominator of b1, in m or kg m-2. - real :: h_tr ! h_tr is h at tracer points with a h_neglect added to - ! ensure positive definiteness, in m or kg m-2. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected, in m. + b1, & !< b1 is used by the tridiagonal solver, in m-1 or m2 kg-1. + d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver, ND. + real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the + !! difference in sinking rates across the layer, in m or kg m-2. + !! By construction, 0 <= h_minus_dsink < h_work. + real :: sink(SZI_(G),SZK_(GV)+1) !< The tracer's sinking distances at the + !! interfaces, limited to prevent characteristics from + !! crossing within a single timestep, in m or kg m-2. + real :: b_denom_1 !< The first term in the denominator of b1, in m or kg m-2. + real :: h_tr !< h_tr is h at tracer points with a h_neglect added to + !! ensure positive definiteness, in m or kg m-2. + real :: h_neglect !< A thickness that is so small it is usually lost + !! in roundoff and can be neglected, in m. logical :: convert_flux = .true. @@ -80,31 +86,31 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & !$OMP h_old,convert_flux,h_neglect,eb,tr) & !$OMP private(sink,h_minus_dsink,b_denom_1,b1,d1,h_tr,c1) !$OMP do - do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo; enddo + do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo ; enddo if (present(sfc_flux)) then - if(convert_flux) then + if (convert_flux) then !$OMP do do j = js, je; do i = is,ie sfc_src(i,j) = (sfc_flux(i,j)*dt) * GV%kg_m2_to_H - enddo; enddo + enddo ; enddo else !$OMP do do j = js, je; do i = is,ie sfc_src(i,j) = sfc_flux(i,j) - enddo; enddo + enddo ; enddo endif endif if (present(btm_flux)) then - if(convert_flux) then + if (convert_flux) then !$OMP do do j = js, je; do i = is,ie btm_src(i,j) = (btm_flux(i,j)*dt) * GV%kg_m2_to_H - enddo; enddo + enddo ; enddo else !$OMP do do j = js, je; do i = is,ie btm_src(i,j) = btm_flux(i,j) - enddo; enddo + enddo ; enddo endif endif @@ -225,14 +231,17 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim real, intent(in ) :: dt !< Time-step over which forcing is applied (s) type(forcing), intent(in ) :: fluxes !< Surface fluxes container real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< Layer thickness in H units - real, intent(in ) :: evap_CFL_limit - real, intent(in ) :: minimum_forcing_depth - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: in_flux_optional ! The total time-integrated amount of tracer! - ! that enters with freshwater - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional ! The total time-integrated amount of tracer! - ! that leaves with freshwater - !< Optional flag to determine whether h should be updated - logical, optional, intent(in) :: update_h_opt + real, intent(in ) :: evap_CFL_limit !< Limit on the fraction of the + !! water that can be fluxed out of the top + !! layer in a timestep (nondim) + real, intent(in ) :: minimum_forcing_depth !< The smallest depth over + !! which fluxes can be applied, in m + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: in_flux_optional !< The total time-integrated + !! amount of tracer that enters with freshwater + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: out_flux_optional !< The total time-integrated + !! amount of tracer that leaves with freshwater + logical, optional, intent(in) :: update_h_opt !< Optional flag to determine whether + !! h should be updated integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) @@ -245,13 +254,13 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim netMassIn, & ! mass entering ocean surface (H units) over a time step netMassOut ! mass leaving ocean surface (H units) over a time step - real, dimension(SZI_(G), SZK_(G)) :: h2d, Tr2d - real, dimension(SZI_(G),SZJ_(G)) :: in_flux ! The total time-integrated amount of tracer! - ! that enters with freshwater - real, dimension(SZI_(G),SZJ_(G)) :: out_flux ! The total time-integrated amount of tracer! - ! that leaves with freshwater - real, dimension(SZI_(G)) :: in_flux_1d, out_flux_1d - real :: hGrounding(maxGroundings) + real, dimension(SZI_(G), SZK_(G)) :: h2d, Tr2d + real, dimension(SZI_(G),SZJ_(G)) :: in_flux ! The total time-integrated amount of tracer! + ! that enters with freshwater + real, dimension(SZI_(G),SZJ_(G)) :: out_flux ! The total time-integrated amount of tracer! + ! that leaves with freshwater + real, dimension(SZI_(G)) :: in_flux_1d, out_flux_1d + real :: hGrounding(maxGroundings) real :: Tr_in logical :: update_h integer :: i, j, is, ie, js, je, k, nz, n, nsw @@ -260,15 +269,15 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke ! If no freshwater fluxes, nothing needs to be done in this routine - if ( (.not. ASSOCIATED(fluxes%netMassIn)) .or. (.not. ASSOCIATED(fluxes%netMassOut)) ) return + if ( (.not. associated(fluxes%netMassIn)) .or. (.not. associated(fluxes%netMassOut)) ) return in_flux(:,:) = 0.0 ; out_flux(:,:) = 0.0 - if(present(in_flux_optional)) then + if (present(in_flux_optional)) then do j=js,je ; do i=is,ie in_flux(i,j) = in_flux_optional(i,j) - enddo; enddo + enddo ; enddo endif - if(present(out_flux_optional)) then + if (present(out_flux_optional)) then do j=js,je ; do i=is,ie out_flux(i,j) = out_flux_optional(i,j) enddo ; enddo diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 0a11de9c1e..8483bf2b6f 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -443,13 +443,12 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by !! a previous call to !! call_tracer_register. - logical, intent(in) :: debug !< Calculates checksums - real, optional,intent(in) :: evap_CFL_limit !< Limits how much water - !! can be fluxed out of the top layer - !! Stored previously in diabatic] CS. - real, optional,intent(in) :: minimum_forcing_depth !< The smallest depth - !! over which fluxes can be applied - !! Stored previously in diabatic CS. + logical, intent(in) :: debug !< If true calculate checksums + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of + !! the water that can be fluxed out + !! of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over + !! which fluxes can be applied, in m ! This subroutine calls all registered tracer column physics ! subroutines. @@ -596,36 +595,37 @@ end subroutine call_tracer_column_fns !> This subroutine calls all registered tracer packages to enable them to !! add to the surface state returned to the coupler. These routines are optional. subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_units, & - num_stocks, stock_index, got_min_max,global_min, global_max,xgmin, & - ygmin, zgmin, xgmax, ygmax, zgmax) + num_stocks, stock_index, got_min_max, global_min, global_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) real, dimension(NIMEM_,NJMEM_,NKMEM_), & intent(in) :: h !< Layer thicknesses, in H !! (usually m or kg m-2). - real, dimension(:), intent(out) :: stock_values + real, dimension(:), intent(out) :: stock_values !< The integrated amounts of a tracer + !! on the current PE, usually in kg x concentration. 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(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to !! call_tracer_register. - character(len=*), dimension(:), optional, & - intent(out) :: stock_names !< Diagnostic names to use for each - !! stock. - character(len=*), dimension(:), optional, & - intent(out) :: stock_units !< Units to use in the metadata for - !! each stock. - integer, optional, & - intent(out) :: num_stocks !< The number of tracer stocks being - !! returned. - integer, optional, & - intent(in) :: stock_index !< The integer stock index from - !! stocks_constans_mod of the stock to be returned. If this is + character(len=*), dimension(:), & + optional, intent(out) :: stock_names !< Diagnostic names to use for each stock. + character(len=*), dimension(:), & + optional, intent(out) :: stock_units !< Units to use in the metadata for each stock. + integer, optional, intent(out) :: num_stocks !< The number of tracer stocks being returned. + integer, optional, intent(in) :: stock_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. - logical, dimension(:), optional, & - intent(inout) :: got_min_max - real, dimension(:), optional, & - intent(out) :: global_min, global_max - real, dimension(:), optional, & - intent(out) :: xgmin, ygmin, zgmin, xgmax, ygmax, zgmax + logical, dimension(:), & + optional, intent(inout) :: got_min_max !< Indicates whether the global min and + !! max are found for each tracer + real, dimension(:), optional, intent(out) :: global_min !< The global minimum of each tracer + real, dimension(:), optional, intent(out) :: global_max !< The global maximum of each tracer + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum ! This subroutine calls all registered tracer packages to enable them to ! add to the surface state returned to the coupler. These routines are optional. @@ -707,8 +707,9 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, CS, stock_names, stock_uni call store_stocks("MOM_generic_tracer", ns, names, units, values, index, stock_values, & 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 ,& - G, CS%MOM_generic_tracer_CSp,names, units) + nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& + G, CS%MOM_generic_tracer_CSp,names, units) endif #endif @@ -735,16 +736,26 @@ end subroutine call_tracer_stocks !> This routine stores the stocks and does error handling for call_tracer_stocks. subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) - character(len=*), intent(in) :: pkg_name - integer, intent(in) :: ns - character(len=*), dimension(:), intent(in) :: names, units - real, dimension(:), intent(in) :: values - integer, intent(in) :: index - real, dimension(:), intent(inout) :: stock_values - character(len=*), intent(inout) :: set_pkg_name - integer, intent(in) :: max_ns - integer, intent(inout) :: ns_tot - character(len=*), dimension(:), optional, intent(inout) :: stock_names, stock_units + character(len=*), intent(in) :: pkg_name !< The tracer package name + integer, intent(in) :: ns !< The number of stocks associated with this tracer package + character(len=*), dimension(:), & + 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 + 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 + 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. + integer, intent(in) :: max_ns !< The maximum size of the master stock list + integer, intent(inout) :: ns_tot !< The total number of stocks in the master list + character(len=*), dimension(:), & + optional, intent(inout) :: stock_names !< Diagnostic names to use for each stock in the master list + character(len=*), dimension(:), & + optional, intent(inout) :: stock_units !< Units to use in the metadata for each stock in the master list ! This routine stores the stocks and does error handling for call_tracer_stocks. character(len=16) :: ind_text, ns_text, max_text @@ -830,7 +841,8 @@ subroutine call_tracer_surface_state(state, h, G, CS) end subroutine call_tracer_surface_state subroutine tracer_flow_control_end(CS) - type(tracer_flow_control_CS), pointer :: CS + type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a + !! previous call to call_tracer_register. if (CS%use_USER_tracer_example) & call USER_tracer_example_end(CS%USER_tracer_example_CSp) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 056ed8fc96..bdadb4e4e0 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -42,14 +42,17 @@ module MOM_tracer_hor_diff ! where passivity is the ratio between along-isopycnal ! tracer mixing and thickness mixing real :: KhTr_passivity_min ! Passivity minimum (default = 1/2) - real :: ML_KhTR_scale ! With Diffuse_ML_interior, the ratio of the truly - ! horizontal diffusivity in the mixed layer to the - ! epipycnal diffusivity. Nondim. + real :: ML_KhTR_scale ! With Diffuse_ML_interior, the ratio of the + ! truly horizontal diffusivity in the mixed + ! layer to the epipycnal diffusivity. Nondim. + real :: max_diff_CFL ! If positive, locally limit the along-isopycnal + ! tracer diffusivity to keep the diffusive CFL + ! locally at or below this value. Nondim. logical :: Diffuse_ML_interior ! If true, diffuse along isopycnals between ! the mixed layer and the interior. logical :: check_diffusive_CFL ! If true, automatically iterate the diffusion - ! to ensure that the diffusive equivalent of the CFL - ! limit is not violated. + ! to ensure that the diffusive equivalent of + ! the CFL limit is not violated. logical :: use_neutral_diffusion ! If true, use the neutral_diffusion module from within ! tracer_hor_diff. type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() ! Control structure for neutral diffusion. @@ -84,24 +87,30 @@ module MOM_tracer_hor_diff !! Multiple iterations are used (if necessary) so that there is no limit !! on the acceptable time increment. subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) - type(ocean_grid_type), intent(inout) :: G !< Grid type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness (m or kg m-2) - real, intent(in) :: dt !< time step (seconds) - type(MEKE_type), pointer :: MEKE !< MEKE type - type(VarMix_CS), pointer :: VarMix !< Variable mixing type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(tracer_hor_diff_CS), pointer :: CS !< module control structure - type(tracer_registry_type), pointer :: Reg !< registered tracers - type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available - !! thermodynamic fields, including potential temp and - !! salinity or mixed layer density. Absent fields have - !! NULL ptrs, and these may (probably will) point to - !! some of the same arrays as Tr does. tv is required - !! for epipycnal mixing between mixed layer and the interior. + type(ocean_grid_type), intent(inout) :: G !< Grid type + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness (m or kg m-2) + real, intent(in) :: dt !< time step (seconds) + type(MEKE_type), pointer :: MEKE !< MEKE type + type(VarMix_CS), pointer :: VarMix !< Variable mixing type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(tracer_hor_diff_CS), pointer :: CS !< module control structure + type(tracer_registry_type), pointer :: Reg !< registered tracers + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields, including potential temp and + !! salinity or mixed layer density. Absent fields have + !! NULL ptrs, and these may (probably will) point to + !! some of the same arrays as Tr does. tv is required + !! for epipycnal mixing between mixed layer and the interior. ! Optional inputs for offline tracer transport - logical, optional :: do_online_flag - real, dimension(SZIB_(G),SZJ_(G)), optional, intent(in) :: read_khdt_x - real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: read_khdt_y + logical, optional, intent(in) :: do_online_flag !< If present and true, do online + !! tracer transport with stored velcities. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(in) :: read_khdt_x !< If present, these are the zonal + !! diffusivities from previous run. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(in) :: read_khdt_y !< If present, these are the meridional + !! diffusivities from previous run. real, dimension(SZI_(G),SZJ_(G)) :: & @@ -125,6 +134,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla ! to time-integrated fluxes, in m3 or kg. Kh_v ! Tracer mixing coefficient at u-points, in m2 s-1. + real :: khdt_max ! The local limiting value of khdt_x or khdt_y, in 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 @@ -187,106 +197,139 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla if (CS%show_call_tree) call callTree_waypoint("Calculating diffusivity (tracer_hordiff)") if (do_online) then - if (use_VarMix) then - !$OMP parallel default(none) shared(is,ie,js,je,CS,VarMix,MEKE,Resoln_scaled, & - !$OMP Kh_u,Kh_v,khdt_x,dt,G,khdt_y,use_Eady) & - !$OMP private(Kh_loc,Rd_dx) - !$OMP do + if (use_VarMix) then + !$OMP parallel do default(shared) private(Kh_loc,Rd_dx) + do j=js,je ; do I=is-1,ie + Kh_loc = CS%KhTr + if (use_Eady) Kh_loc = Kh_loc + CS%KhTr_Slope_Cff*VarMix%L2u(I,j)*VarMix%SN_u(I,j) + if (associated(MEKE%Kh)) & + Kh_Loc = Kh_Loc + MEKE%KhTr_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i+1,j)) + if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) + if (Resoln_scaled) & + Kh_Loc = Kh_Loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) + Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) + if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity + Rd_dx=0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i+1,j) ) ! Rd/dx at u-points + Kh_loc=Kh_u(I,j)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max + Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + endif + enddo ; enddo + !$OMP parallel do default(shared) private(Kh_loc,Rd_dx) + do J=js-1,je ; do i=is,ie + Kh_loc = CS%KhTr + if (use_Eady) Kh_loc = Kh_loc + CS%KhTr_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) + if (associated(MEKE%Kh)) & + Kh_Loc = Kh_Loc + MEKE%KhTr_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i,j+1)) + if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) + if (Resoln_scaled) & + Kh_Loc = Kh_Loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) + Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) + if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity + Rd_dx=0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i,j+1) ) ! Rd/dx at v-points + Kh_loc=Kh_v(I,j)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max + Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + endif + enddo ; enddo + + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + khdt_x(I,j) = dt*(Kh_u(I,j)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + khdt_y(i,J) = dt*(Kh_v(i,J)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + enddo ; enddo + elseif (Resoln_scaled) then + !$OMP parallel do default(shared) private(Res_fn) + do j=js,je ; do I=is-1,ie + Res_fn = 0.5 * (VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) + Kh_u(I,j) = max(CS%KhTr * Res_fn, CS%KhTr_min) + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) * Res_fn + enddo ; enddo + !$OMP parallel do default(shared) private(Res_fn) + do J=js-1,je ; do i=is,ie + Res_fn = 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) + Kh_v(i,J) = max(CS%KhTr * Res_fn, CS%KhTr_min) + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn + enddo ; enddo + else ! Use a simple constant diffusivity. + if (CS%id_KhTr_u > 0) then + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - Kh_loc = CS%KhTr - if (use_Eady) Kh_loc = Kh_loc + CS%KhTr_Slope_Cff*VarMix%L2u(I,j)*VarMix%SN_u(I,j) - if (associated(MEKE%Kh)) & - Kh_Loc = Kh_Loc + MEKE%KhTr_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i+1,j)) - if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) - if (Resoln_scaled) & - Kh_Loc = Kh_Loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) - Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) - if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity - Rd_dx=0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i+1,j) ) ! Rd/dx at u-points - Kh_loc=Kh_u(I,j)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) - if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max - Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) ! Re-apply min - endif + Kh_u(I,j) = CS%KhTr + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo - !$OMP do + endif + if (CS%id_KhTr_v > 0) then + !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - Kh_loc = CS%KhTr - if (use_Eady) Kh_loc = Kh_loc + CS%KhTr_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) - if (associated(MEKE%Kh)) & - Kh_Loc = Kh_Loc + MEKE%KhTr_fac*sqrt(MEKE%Kh(i,j)*MEKE%Kh(i,j+1)) - if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) - if (Resoln_scaled) & - Kh_Loc = Kh_Loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) - Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) - if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity - Rd_dx=0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i,j+1) ) ! Rd/dx at v-points - Kh_loc=Kh_v(I,j)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) - if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max - Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) ! Re-apply min - endif + Kh_v(i,J) = CS%KhTr + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + enddo ; enddo + else + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo + endif + endif ! VarMix - !$OMP do + if (CS%max_diff_CFL > 0.0) then + if ((CS%id_KhTr_u > 0) .or. (CS%id_KhTr_h > 0)) then + !$OMP parallel do default(shared) private(khdt_max) do j=js,je ; do I=is-1,ie - khdt_x(I,j) = dt*(Kh_u(I,j)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) - enddo ; enddo - !$OMP do - do J=js-1,je ; do i=is,ie - khdt_y(i,J) = dt*(Kh_v(i,J)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + khdt_max = 0.125*CS%max_diff_CFL * min(G%areaT(i,j), G%areaT(i+1,j)) + if (khdt_x(I,j) > khdt_max) then + khdt_x(I,j) = khdt_max + if (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j)) > 0.0) & + Kh_u(I,j) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + endif enddo ; enddo - !$OMP end parallel - elseif (Resoln_scaled) then - !$OMP parallel default(none) shared(is,ie,js,je,VarMix,Kh_u,Kh_v,khdt_x,khdt_y,CS,dt,G) & - !$OMP private(Res_fn) - !$OMP do + else + !$OMP parallel do default(shared) private(khdt_max) do j=js,je ; do I=is-1,ie - Res_fn = 0.5 * (VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) - Kh_u(I,j) = max(CS%KhTr * Res_fn, CS%KhTr_min) - khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) * Res_fn + khdt_max = 0.125*CS%max_diff_CFL * min(G%areaT(i,j), G%areaT(i+1,j)) + khdt_x(I,j) = min(khdt_x(I,j), khdt_max) enddo ; enddo - !$OMP do - do J=js-1,je ; do i=is,ie - Res_fn = 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) - Kh_v(i,J) = max(CS%KhTr * Res_fn, CS%KhTr_min) - khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn + endif + if ((CS%id_KhTr_v > 0) .or. (CS%id_KhTr_h > 0)) then + !$OMP parallel do default(shared) private(khdt_max) + do J=js-1,je ; do i=is,ie + khdt_max = 0.125*CS%max_diff_CFL * min(G%areaT(i,j), G%areaT(i,j+1)) + if (khdt_y(i,J) > khdt_max) then + khdt_y(i,J) = khdt_max + if (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J)) > 0.0) & + Kh_v(i,J) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + endif enddo ; enddo - !$OMP end parallel else - !$OMP parallel default(none) shared(is,ie,js,je,Kh_u,Kh_v,khdt_x,khdt_y,CS,G,dt) - if (CS%id_KhTr_u > 0) then - !$OMP do - do j=js,je ; do I=is-1,ie - Kh_u(I,j) = CS%KhTr - khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) - enddo ; enddo - else - !$OMP do - do j=js,je ; do I=is-1,ie - khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) - enddo ; enddo - endif - if (CS%id_KhTr_v > 0) then - !$OMP do - do J=js-1,je ; do i=is,ie - Kh_v(i,J) = CS%KhTr - khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) - enddo ; enddo - else - !$OMP do - do J=js-1,je ; do i=is,ie - khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) - enddo ; enddo - endif - !$OMP end parallel - endif ! VarMix + !$OMP parallel do default(shared) private(khdt_max) + do J=js-1,je ; do i=is,ie + khdt_max = 0.125*CS%max_diff_CFL * min(G%areaT(i,j), G%areaT(i,j+1)) + khdt_y(i,J) = min(khdt_y(i,J), khdt_max) + enddo ; enddo + endif + endif + else ! .not. do_online - khdt_x = read_khdt_x - khdt_y = read_khdt_y + !$OMP parallel do default(shared) + do j=js,je ; do I=is-1,ie + khdt_x(I,j) = read_khdt_x(I,j) + enddo ; enddo + !$OMP parallel do default(shared) + do J=js-1,je ; do i=is,ie + khdt_y(i,J) = read_khdt_y(i,J) + enddo ; enddo call pass_vector(khdt_x,khdt_y,G%Domain) endif ! do_online - - if (CS%check_diffusive_CFL) then if (CS%show_call_tree) call callTree_waypoint("Checking diffusive CFL (tracer_hordiff)") max_CFL = 0.0 @@ -298,9 +341,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla call cpu_clock_begin(id_clock_sync) call max_across_PEs(max_CFL) call cpu_clock_end(id_clock_sync) - num_itts = max(1,ceiling(max_CFL)) - I_numitts = 1.0 ; if (num_itts > 1) I_numitts = 1.0 / (real(num_itts)) - if(CS%id_CFL > 0) call post_data(CS%id_CFL, CFL, CS%diag, mask=G%mask2dT) + num_itts = max(1, ceiling(max_CFL - 4.0*EPSILON(max_CFL))) + I_numitts = 1.0 / (real(num_itts)) + if (CS%id_CFL > 0) call post_data(CS%id_CFL, CFL, CS%diag, mask=G%mask2dT) + elseif (CS%max_diff_CFL > 0.0) then + num_itts = max(1, ceiling(CS%max_diff_CFL - 4.0*EPSILON(CS%max_diff_CFL))) + I_numitts = 1.0 / (real(num_itts)) else num_itts = 1 ; I_numitts = 1.0 endif @@ -356,9 +402,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, CS, Reg, tv, do_online_fla if (CS%show_call_tree) call callTree_waypoint("Calculating horizontal diffusion (tracer_hordiff)") do itt=1,num_itts call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,I_numitts,CS,G,GV,khdt_y,h, & -!$OMP h_neglect,khdt_x,ntr,Idt,Reg) & -!$OMP private(scale,Coef_y,Coef_x,Ihdxdy,dTr) + !$OMP parallel do default(shared) private(scale,Coef_y,Coef_x,Ihdxdy,dTr) do k=1,nz scale = I_numitts if (CS%Diffuse_ML_interior) then @@ -679,7 +723,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & tmp = h_srt(i,k2-1,j) ; h_srt(i,k2-1,j) = h_srt(i,k2,j) ; h_srt(i,k2,j) = tmp enddo endif ; enddo - enddo; enddo + enddo ; enddo !$OMP do do j=js-1,je+1 max_srt(j) = 0 @@ -1363,24 +1407,29 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) "The maximum along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0) call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", CS%KhTr_passivity_coeff, & - "The coefficient that scales deformation radius over \n"//& - "grid-spacing in passivity, where passiviity is the ratio \n"//& - "between along isopycnal mxiing of tracers to thickness mixing. \n"//& - "A non-zero value enables this parameterization.", & - units="nondim", default=0.0) + "The coefficient that scales deformation radius over \n"//& + "grid-spacing in passivity, where passiviity is the ratio \n"//& + "between along isopycnal mxiing of tracers to thickness mixing. \n"//& + "A non-zero value enables this parameterization.", & + units="nondim", default=0.0) call get_param(param_file, mdl, "KHTR_PASSIVITY_MIN", CS%KhTr_passivity_min, & - "The minimum passivity which is the ratio between \n"//& - "along isopycnal mxiing of tracers to thickness mixing. \n", & - units="nondim", default=0.5) - call get_param(param_file, mdl, "DT", CS%dt, fail_if_missing=.true., & - desc="The (baroclinic) dynamics time step.", units="s") + "The minimum passivity which is the ratio between \n"//& + "along isopycnal mxiing of tracers to thickness mixing. \n", & + units="nondim", default=0.5) call get_param(param_file, mdl, "DIFFUSE_ML_TO_INTERIOR", CS%Diffuse_ML_interior, & "If true, enable epipycnal mixing between the surface \n"//& "boundary layer and the interior.", default=.false.) call get_param(param_file, mdl, "CHECK_DIFFUSIVE_CFL", CS%check_diffusive_CFL, & "If true, use enough iterations the diffusion to ensure \n"//& "that the diffusive equivalent of the CFL limit is not \n"//& - "violated. If false, always use 1 iteration.", default=.false.) + "violated. If false, always use the greater of 1 or \n"//& + "MAX_TR_DIFFUSION_CFL iteration.", default=.false.) + call get_param(param_file, mdl, "MAX_TR_DIFFUSION_CFL", CS%max_diff_CFL, & + "If positive, locally limit the along-isopycnal tracer \n"//& + "diffusivity to keep the diffusive CFL locally at or \n"//& + "below this value. The number of diffusive iterations \n"//& + "is often this value or the next greater integer.", & + units="nondim", default=-1.0) 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, & @@ -1429,7 +1478,7 @@ subroutine tracer_hor_diff_init(Time, G, param_file, diag, EOS, CS) end subroutine tracer_hor_diff_init subroutine tracer_hor_diff_end(CS) - type(tracer_hor_diff_CS), pointer :: CS + type(tracer_hor_diff_CS), pointer :: CS !< module control structure call neutral_diffusion_end(CS%neutral_diffusion_CSp) if (associated(CS)) deallocate(CS) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index effbc6d1fe..06ac26d120 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -32,6 +32,7 @@ module MOM_tracer_registry public register_tracer_diagnostics, post_tracer_diagnostics, post_tracer_transport_diagnostics public preALE_tracer_diagnostics, postALE_tracer_diagnostics public tracer_registry_init, lock_tracer_registry, tracer_registry_end +public tracer_name_lookup !> The tracer type type, public :: tracer_type @@ -157,10 +158,14 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit real, dimension(:,:,:), optional, pointer :: ad_y !< diagnostic y-advective flux (CONC m3/s or CONC*kg/s) real, dimension(:,:,:), optional, pointer :: df_x !< diagnostic x-diffusive flux (CONC m3/s or CONC*kg/s) real, dimension(:,:,:), optional, pointer :: df_y !< diagnostic y-diffusive flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux (CONC m3/s or CONC*kg/s) - real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: ad_2d_x !< vert sum of diagnostic x-advect flux + !! (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: ad_2d_y !< vert sum of diagnostic y-advect flux + !! (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: df_2d_x !< vert sum of diagnostic x-diffuse flux + !! (CONC m3/s or CONC*kg/s) + real, dimension(:,:), optional, pointer :: df_2d_y !< vert sum of diagnostic y-diffuse flux + !! (CONC m3/s or CONC*kg/s) real, dimension(:,:,:), optional, pointer :: advection_xy !< convergence of lateral advective tracer fluxes logical, optional, intent(in) :: registry_diags !< If present and true, use the registry for @@ -172,13 +177,16 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit character(len=*), optional, intent(in) :: flux_units !< The units for the fluxes of this tracer. real, optional, intent(in) :: flux_scale !< A scaling factor used to convert the fluxes !! of this tracer to its desired units. - character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of this tracer. + character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of + !! this tracer. real, optional, intent(in) :: convergence_scale !< A scaling factor used to convert the flux !! convergence of this tracer to its desired units. - character(len=*), optional, intent(in) :: cmor_tendprefix !< The CMOR name for the layer-integrated tendencies of this tracer. - integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the character - !! string template to use in labeling diagnostics - type(MOM_restart_CS), optional, pointer :: restart_CS !< A pointer to the restart control structure; + character(len=*), optional, intent(in) :: cmor_tendprefix !< The CMOR name for the layer-integrated + !! tendencies of this tracer. + integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the + !! character string template to use in + !! labeling diagnostics + type(MOM_restart_CS), optional, pointer :: restart_CS !< A pointer to the restart control structure !! this tracer will be registered for !! restarts if this argument is present logical, optional, intent(in) :: mandatory !< If true, this tracer must be read @@ -719,11 +727,11 @@ end subroutine MOM_tracer_chksum !> Calculates and prints the global inventory of all tracers in the registry. subroutine MOM_tracer_chkinv(mesg, G, h, Tr, ntr) - character(len=*), intent(in) :: mesg !< message that appears on the chksum lines - type(ocean_grid_type), intent(in) :: G !< ocean grid structure - type(tracer_type), intent(in) :: Tr(:) !< array of all of registered tracers - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses - integer, intent(in) :: ntr !< number of registered tracers + character(len=*), intent(in) :: mesg !< message that appears on the chksum lines + type(ocean_grid_type), intent(in) :: G !< ocean grid structure + type(tracer_type), dimension(:), intent(in) :: Tr !< array of all of registered tracers + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses + integer, intent(in) :: ntr !< number of registered tracers real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: tr_inv !< Tracer inventory real :: total_inv @@ -735,12 +743,25 @@ subroutine MOM_tracer_chkinv(mesg, G, h, Tr, ntr) do k=1,nz ; do j=js,je ; do i=is,ie tr_inv(i,j,k) = Tr(m)%t(i,j,k)*h(i,j,k)*G%areaT(i,j)*G%mask2dT(i,j) enddo ; enddo ; enddo - total_inv = reproducing_sum(tr_inv, is, ie, js, je) + total_inv = reproducing_sum(tr_inv, is+(1-G%isd), ie+(1-G%isd), js+(1-G%jsd), je+(1-G%jsd)) if (is_root_pe()) write(0,'(A,1X,A5,1X,ES25.16,1X,A)') "h-point: inventory", Tr(m)%name, total_inv, mesg enddo end subroutine MOM_tracer_chkinv +!> Find a tracer in the tracer registry by name. +subroutine tracer_name_lookup(Reg, tr_ptr, name) + type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry + type(tracer_type), pointer :: tr_ptr !< target or pointer to the tracer array + character(len=32), intent(in) :: name !< tracer name + + integer n + do n=1,Reg%ntr + if (lowercase(Reg%Tr(n)%name) == lowercase(name)) tr_ptr => Reg%Tr(n) + enddo + +end subroutine tracer_name_lookup + !> Initialize the tracer registry. subroutine tracer_registry_init(param_file, Reg) type(param_file_type), intent(in) :: param_file !< open file to parse for model parameters diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 39e6e668e3..58c8955234 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -98,12 +98,15 @@ module advection_test_tracer contains function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(advection_test_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -203,16 +206,23 @@ end function register_advection_test_tracer subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(advection_test_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. ! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. @@ -307,14 +317,29 @@ end subroutine initialize_advection_test_tracer subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(advection_test_tracer_CS), pointer :: CS - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_advection_test_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -349,7 +374,7 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -398,12 +423,15 @@ end subroutine advection_test_tracer_surface_state 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 real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(advection_test_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index + 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. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. integer :: advection_test_stock ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index @@ -449,7 +477,8 @@ function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) end function advection_test_stock subroutine advection_test_tracer_end(CS) - type(advection_test_tracer_CS), pointer :: 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 diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 03cf06fdfa..6cfa91049f 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -67,12 +67,15 @@ module boundary_impulse_tracer !> Read in runtime options and add boundary impulse tracer to tracer registry function register_boundary_impulse_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in ) :: HI - type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure - type(param_file_type), intent(in ) :: param_file !< A structure to parse for run-time parameters - type(boundary_impulse_tracer_CS), pointer, intent(inout) :: CS - type(tracer_registry_type), pointer, intent(inout) :: tr_Reg - type(MOM_restart_CS), pointer, intent(inout) :: 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(param_file_type), intent(in ) :: param_file !< A structure to parse for run-time parameters + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -160,17 +163,25 @@ end function register_boundary_impulse_tracer !> Initialize tracer from restart or set to 1 at surface to initialize subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp, tv) - logical, intent(in ) :: restart - type(time_type), target, intent(in ) :: day - type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in ) :: diag - type(ocean_OBC_type), pointer, intent(inout) :: OBC - type(boundary_impulse_tracer_CS), pointer,intent(inout) :: CS - type(sponge_CS), pointer, intent(inout) :: sponge_CSp - type(diag_to_Z_CS), pointer, intent(inout) :: diag_to_Z_CSp - type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various thermodynamic variables + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables ! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. @@ -225,18 +236,34 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, h, diag, OBC, end subroutine initialize_boundary_impulse_tracer ! Apply source or sink at boundary and do vertical diffusion -subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, debug, & - evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in ) :: h_old, h_new, ea, eb - type(forcing), intent(in ) :: fluxes - real, intent(in ) :: dt !< The amount of time covered by this call, in s - type(boundary_impulse_tracer_CS), pointer, intent(inout) :: CS - type(thermo_var_ptrs), intent(in ) :: tv !< A structure pointing to various thermodynamic variables - logical, intent(in ) :: debug - real, optional, intent(in ) :: evap_CFL_limit - real, optional, intent(in ) :: minimum_forcing_depth +subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & + tv, debug, evap_CFL_limit, minimum_forcing_depth) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_boundary_impulse_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + logical, intent(in) :: debug !< If true calculate checksums + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -282,7 +309,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,1), dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) @@ -292,7 +319,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 @@ -312,11 +339,16 @@ 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_(G)), intent(in ) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent( out) :: stocks - type(boundary_impulse_tracer_CS), pointer, intent(in ) :: CS - character(len=*), dimension(:), intent( out) :: names - character(len=*), dimension(:), intent( out) :: units - integer, optional, intent(in ) :: stock_index + real, dimension(:), intent( out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. + 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. + character(len=*), dimension(:), intent( out) :: units !< The units of the stocks calculated. + integer, optional, intent(in ) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: 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. @@ -332,7 +364,7 @@ function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) ! (out) units - the units of the stocks calculated. ! (in,opt) stock_index - the coded index of a specific stock being sought. ! Return value: the number of stocks calculated here. - integer :: boundary_impulse_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 @@ -397,7 +429,8 @@ end subroutine boundary_impulse_tracer_surface_state ! Performs finalization of boundary impulse tracer subroutine boundary_impulse_tracer_end(CS) - type(boundary_impulse_tracer_CS), pointer :: 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 diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index dcd2b6fecb..871b7cdc58 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -233,7 +233,7 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C z_bot = z_bot + h(i,j,k)*GV%H_to_m enddo endif - enddo; enddo + enddo ; enddo enddo end subroutine initialize_dye_tracer @@ -245,25 +245,29 @@ end subroutine initialize_dye_tracer !! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to - !! any possible forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to register_dye_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_dye_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified @@ -283,7 +287,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -312,7 +316,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS z_bot = z_bot + h_new(i,j,k)*GV%H_to_m enddo endif - enddo; enddo + enddo ; enddo enddo end subroutine dye_tracer_column_physics @@ -399,7 +403,8 @@ end subroutine dye_tracer_surface_state !> Clean up any allocated memory after the run. subroutine regional_dyes_end(CS) - type(dye_tracer_CS), pointer :: 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 diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index d9ca3ff9f1..10d3d5108b 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -69,8 +69,6 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) #include "version_variable.h" character(len=40) :: mdl = "dyed_obc_tracer" ! This module's name. character(len=200) :: inputdir - character(len=48) :: var_name ! The variable's name. - character(len=48) :: desc_name ! The variable's descriptor. 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() @@ -211,25 +209,29 @@ end subroutine initialize_dyed_obc_tracer !! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to - !! any possible forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous - !! call to dyed_obc_register_tracer. - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to dyed_obc_register_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! Local variables real :: b1(SZI_(G)) ! b1 and c1 are variables used by the @@ -245,7 +247,7 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -260,7 +262,8 @@ end subroutine dyed_obc_tracer_column_physics !> Clean up memory allocations, if any. subroutine dyed_obc_tracer_end(CS) - type(dyed_obc_tracer_CS), pointer :: 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 @@ -273,7 +276,7 @@ end subroutine dyed_obc_tracer_end !> \namespace dyed_obc_tracer !! * !! By Kate Hedstrom, 2017, copied from DOME tracers and also * -!! dye_example. * +!! dye_example. * !! * !! This file contains an example of the code that is needed to set * !! up and use a set of dynamically passive tracers. These tracers * diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 4f08dd7db1..c284a4d452 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -109,12 +109,15 @@ module ideal_age_example contains function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ideal_age_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -239,16 +242,23 @@ end function register_ideal_age_tracer subroutine initialize_ideal_age_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(ideal_age_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. ! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. @@ -333,14 +343,29 @@ end subroutine initialize_ideal_age_tracer subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(ideal_age_tracer_CS), pointer :: CS - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_ideal_age_tracer. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -378,7 +403,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -422,13 +447,17 @@ end subroutine ideal_age_tracer_column_physics 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 - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ideal_age_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index + 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. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. integer :: ideal_age_stock ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index @@ -508,7 +537,9 @@ subroutine ideal_age_tracer_surface_state(state, h, G, CS) end subroutine ideal_age_tracer_surface_state subroutine ideal_age_example_end(CS) - type(ideal_age_tracer_CS), pointer :: 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 diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index e7071f9431..47edfac6e6 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -114,12 +114,15 @@ module oil_tracer contains function register_oil_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(oil_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(oil_tracer_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -247,16 +250,23 @@ end function register_oil_tracer subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(oil_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. ! This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) ! and it sets up the tracer output. @@ -301,7 +311,7 @@ subroutine initialize_oil_tracer(restart, day, G, GV, h, diag, OBC, CS, & CS%oil_source_i=i CS%oil_source_j=j endif - enddo; enddo + enddo ; enddo CS%Time => day CS%diag => diag @@ -351,15 +361,30 @@ end subroutine initialize_oil_tracer subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(oil_tracer_CS), pointer :: CS - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_oil_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -397,7 +422,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) @@ -462,11 +487,14 @@ 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_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks - type(oil_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. + 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. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. integer :: oil_stock ! This function calculates the mass-weighted integral of all tracer stocks, ! returning the number of stocks it has calculated. If the stock_index @@ -546,7 +574,8 @@ subroutine oil_tracer_surface_state(state, h, G, CS) end subroutine oil_tracer_surface_state subroutine oil_tracer_end(CS) - type(oil_tracer_CS), pointer :: 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 diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 479de3d059..ec13de8df2 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -88,12 +88,15 @@ module pseudo_salt_tracer contains function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI + 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(pseudo_salt_tracer_CS), pointer :: CS - type(tracer_registry_type), pointer :: tr_Reg - type(MOM_restart_CS), pointer :: restart_CS + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! This subroutine is used to register tracer fields and subroutines ! to be used with MOM. ! Arguments: HI - A horizontal index type structure. @@ -149,16 +152,23 @@ end function register_pseudo_salt_tracer subroutine initialize_pseudo_salt_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp, tv) - logical, intent(in) :: restart - type(time_type), target, intent(in) :: day + logical, intent(in) :: restart !< .true. if the fields have already + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag - type(ocean_OBC_type), pointer :: OBC - type(pseudo_salt_tracer_CS), pointer :: CS - type(sponge_CS), pointer :: sponge_CSp - type(diag_to_Z_CS), pointer :: diag_to_Z_CSp + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + !! diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. + type(diag_to_Z_CS), pointer :: diag_to_Z_CSp !< A pointer to the control structure + !! for diagnostics in depth space. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables ! This subroutine initializes the tracer fields in CS%ps(:,:,:). @@ -215,16 +225,31 @@ end subroutine initialize_pseudo_salt_tracer subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS, tv, debug, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old, h_new, ea, eb - type(forcing), intent(in) :: fluxes - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(pseudo_salt_tracer_CS), pointer :: CS - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables - logical, intent(in) :: debug - real, optional,intent(in) :: evap_CFL_limit - real, optional,intent(in) :: minimum_forcing_depth + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + logical, intent(in) :: debug !< If true calculate checksums + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep (nondim) + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied, in m ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -278,7 +303,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%ps, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth, out_flux_optional=net_salt) call tracer_vertdiff(h_work, ea, eb, dt, CS%ps, G, GV) @@ -290,7 +315,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G CS%diff(i,j,k) = CS%ps(i,j,k)-tv%S(i,j,k) enddo ; enddo ; enddo - if(debug) then + if (debug) then call hchksum(tv%S,"salt post pseudo-salt vertdiff", G%HI) call hchksum(CS%ps,"pseudo_salt post pseudo-salt vertdiff", G%HI) endif @@ -303,12 +328,17 @@ 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_(G)), intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - real, dimension(:), intent(out) :: stocks - type(pseudo_salt_tracer_CS), pointer :: CS - character(len=*), dimension(:), intent(out) :: names - character(len=*), dimension(:), intent(out) :: units - integer, optional, intent(in) :: stock_index - integer :: pseudo_salt_stock + real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + !! tracer, in kg times concentration units. + 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. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. + integer :: pseudo_salt_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. @@ -378,7 +408,8 @@ subroutine pseudo_salt_tracer_surface_state(state, h, G, CS) end subroutine pseudo_salt_tracer_surface_state subroutine pseudo_salt_tracer_end(CS) - type(pseudo_salt_tracer_CS), pointer :: CS + type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_pseudo_salt_tracer. integer :: m if (associated(CS)) then diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index b5d31ef5fe..c169ce768e 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -89,15 +89,15 @@ module USER_tracer_example !> This subroutine is used to register tracer fields and subroutines !! to be used with MOM. function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(USER_tracer_example_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control !! structure for the tracer advection and - !! diffusion module. - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + !! diffusion module + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure ! Local variables character(len=80) :: name, longname @@ -174,13 +174,13 @@ end function USER_register_tracer_example subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & sponge_CSp, diag_to_Z_CSp) logical, intent(in) :: restart !< .true. if the fields have already - !! been read from a restart file. - type(time_type), target, intent(in) :: day !< Time of the start of the run. + !! been read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thicknesses, in H (usually m or kg m-2) - type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate + type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary @@ -194,11 +194,6 @@ subroutine USER_initialize_tracer(restart, day, G, GV, 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=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. @@ -283,11 +278,6 @@ subroutine USER_initialize_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (associated(OBC)) then call query_vardesc(CS%tr_desc(1), name, caller="USER_initialize_tracer") if (OBC%specified_v_BCs_exist_globally) then - allocate(OBC_tr1_v(G%isd:G%ied,G%jsd:G%jed,nz)) - do k=1,nz ; do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (k < nz/2) then ; OBC_tr1_v(i,j,k) = 0.0 - else ; OBC_tr1_v(i,j,k) = 1.0 ; endif - enddo ; enddo ; enddo ! Steal from updated DOME in the fullness of time. else ! Steal from updated DOME in the fullness of time. @@ -308,23 +298,25 @@ end subroutine USER_initialize_tracer !! The arguments to this subroutine are redundant in that !! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_old !< Layer thickness before entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h_new !< Layer thickness after entrainment, - !! in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: ea !< an array to which the amount of - !! fluid entrained from the layer above during this - !! call will be added, in m or kg m-2. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: eb !< an array to which the amount of - !! fluid entrained from the layer below during this - !! call will be added, in m or kg m-2. - type(forcing), intent(in) :: fluxes !< A structure containing pointers to - !! any possible forcing fields. Unused fields have NULL ptrs. - real, intent(in) :: dt !< The amount of time covered by this call, in s - type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous - !! call to USER_register_tracer_example. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added, in m or kg m-2. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added, in m or kg m-2. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call, in s + type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous + !! call to USER_register_tracer_example. ! Local variables real :: hold0(SZI_(G)) ! The original topmost layer thickness, @@ -412,12 +404,12 @@ function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) !! tracer, in kg times concentration units. 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. - character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. - integer, optional, intent(in) :: stock_index !< the coded index of a specific stock - !! being sought. + character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< The coded index of a specific stock + !! being sought. integer :: USER_tracer_stock !< Return value: the number of - !! stocks calculated here. + !! stocks calculated here. ! Local variables integer :: i, j, k, is, ie, js, je, nz, m @@ -481,7 +473,8 @@ end subroutine USER_tracer_surface_state !> Clean up allocated memory at the end. subroutine USER_tracer_example_end(CS) - type(USER_tracer_example_CS), pointer :: 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 diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 1217394edc..b4d317d289 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -26,9 +26,6 @@ module BFB_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_io, only : close_file, create_file, fieldtype, file_exists -use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE -use MOM_io, only : write_field, slasher use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS use MOM_tracer_registry, only : tracer_registry_type use MOM_variables, only : thermo_var_ptrs @@ -45,10 +42,11 @@ module BFB_initialization contains +!> This subroutine specifies the vertical coordinate in terms of temperature at the surface and at the bottom. +!! This case is set up in such a way that the temperature of the topmost layer is equal to the SST at the +!! southern edge of the domain. The temperatures are then converted to densities of the top and bottom layers +!! and linearly interpolated for the intermediate layers. subroutine BFB_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) -! This subroutine specifies the vertical coordinate in terms of temperature at the surface and at the bottom. This case is set up in -! such a way that the temperature of the topmost layer is equal to the SST at the southern edge of the domain. The temperatures are -! then converted to densities of the top and bottom layers and linearly interpolated for the intermediate layers. real, dimension(NKMEM_), intent(out) :: Rlay, g_prime type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters @@ -77,18 +75,18 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, param_file, eqn_of_state) g_prime(k) = (Rlay(k) - Rlay(k-1))*GV%g_earth/GV%rho0 else g_prime(k) = GV%g_earth - end if + endif !Rlay(:) = 0.0 !g_prime(:) = 0.0 - end do + enddo if (first_call) call write_BFB_log(param_file) end subroutine BFB_set_coord +!> This subroutine sets up the sponges for the southern bouundary of the domain. Maximum damping occurs +!! within 2 degrees lat of the boundary. The damping linearly decreases northward over the next 2 degrees. subroutine BFB_initialize_sponges_southonly(G, use_temperature, tv, param_file, CSp, h) -! This subroutine sets up the sponges for the southern bouundary of the domain. Maximum damping occurs within 2 degrees lat of the -! boundary. The damping linearly decreases northward over the next 2 degrees. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure logical, intent(in) :: use_temperature type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables @@ -132,7 +130,10 @@ subroutine BFB_initialize_sponges_southonly(G, use_temperature, tv, param_file, "The longitudinal length of the domain.", units="degrees") nlat = slat + lenlat do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz) ; enddo -! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo ! Use for meridional thickness profile initialization + + ! Use for meridional thickness profile initialization +! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo + do i=is,ie; do j=js,je if (G%geoLatT(i,j) < slat+2.0) then ; damp = 1.0 elseif (G%geoLatT(i,j) < slat+4.0) then diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 50f81c8a94..e3aa923179 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -202,12 +202,12 @@ subroutine BFB_buoyancy_forcing(state, fluxes, day, dt, G, CS) ! density in kg m-3 that is being restored toward. if (G%geoLatT(i,j) < CS%lfrslat) then Temp_restore = CS%SST_s - else if (G%geoLatT(i,j) > CS%lfrnlat) then + elseif (G%geoLatT(i,j) > CS%lfrnlat) then Temp_restore = CS%SST_n else Temp_restore = (CS%SST_s - CS%SST_n)/(CS%lfrslat - CS%lfrnlat) * & (G%geoLatT(i,j) - CS%lfrslat) + CS%SST_s - end if + endif density_restore = Temp_restore*CS%drho_dt + CS%Rho0 @@ -225,7 +225,7 @@ subroutine alloc_if_needed(ptr, isd, ied, jsd, jed) ! MOM_diag_mediator, but is here so as to be completely transparent. real, pointer :: ptr(:,:) integer :: isd, ied, jsd, jed - if (.not.ASSOCIATED(ptr)) then + if (.not.associated(ptr)) then allocate(ptr(isd:ied,jsd:jed)) ptr(:,:) = 0.0 endif diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 108c468c5c..3b30e2ee31 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -8,9 +8,6 @@ module DOME2d_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_io, only : close_file, fieldtype, file_exists -use MOM_io, only : open_file, read_data, read_axis_data, SINGLE_FILE -use MOM_io, only : write_field, slasher, vardesc use MOM_sponge, only : sponge_CS, set_up_sponge_field, initialize_sponge use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -74,7 +71,7 @@ subroutine DOME2d_initialize_topography ( D, G, param_file, max_depth ) if ( x <= l1 ) then D(i,j) = bay_depth * max_depth - else if (( x > l1 ) .and. ( x < l2 )) then + elseif (( x > l1 ) .and. ( x < l2 )) then D(i,j) = bay_depth * max_depth + (1.0-bay_depth) * max_depth * & ( x - l1 ) / (l2 - l1) else @@ -312,7 +309,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, end select ! Modify salinity and temperature when z coordinates are used - if ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_ZSTAR ) then + if ( coordinateMode(verticalCoordinate) == REGRIDDING_ZSTAR ) then index_bay_z = Nint ( dome2d_depth_bay * G%ke ) do j = G%jsc,G%jec ; do i = G%isc,G%iec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon @@ -324,7 +321,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, endif ! Z initial conditions ! Modify salinity and temperature when sigma coordinates are used - if ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_SIGMA ) then + if ( coordinateMode(verticalCoordinate) == REGRIDDING_SIGMA ) then do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then @@ -336,8 +333,8 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, ! Modify temperature when rho coordinates are used T(G%isc:G%iec,G%jsc:G%jec,1:G%ke) = 0.0 - if (( coordinateMode(verticalCoordinate) .eq. REGRIDDING_RHO ) .or. & - ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_LAYER )) then + if (( coordinateMode(verticalCoordinate) == REGRIDDING_RHO ) .or. & + ( coordinateMode(verticalCoordinate) == REGRIDDING_LAYER )) then do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then @@ -456,7 +453,7 @@ subroutine DOME2d_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp) h(i,j,k) = eta1D(k) - eta1D(k+1) endif enddo - enddo; enddo + enddo ; enddo ! Store the grid on which the T/S sponge data will reside call initialize_ALE_sponge(Idamp, G, param_file, ACSp, h, nz) diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index a46f95bd38..7d6d5644a9 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -10,7 +10,8 @@ module DOME_initialization use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer -use MOM_tracer_registry, only : tracer_registry_type +use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_tracer_registry, only : tracer_name_lookup use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type @@ -241,9 +242,6 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables - real, pointer, dimension(:,:,:) :: & - OBC_T_v => NULL(), & ! specify the values of T and S that should come - OBC_S_v => NULL() ! boundary conditions, in C and psu. ! The following variables are used to set the target temperature and salinity. real :: T0(SZK_(G)), S0(SZK_(G)) real :: pres(SZK_(G)) ! An array of the reference pressure in Pa. @@ -260,9 +258,11 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) real :: Ri_trans ! The shear Richardson number in the transition ! region of the specified shear profile. character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz + character(len=32) :: name + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, NTR integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment + type(tracer_type), pointer :: tr_ptr is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = G%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -279,13 +279,16 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) Def_Rad = sqrt(D_edge*g_prime_tot) / (1.0e-4*1000.0) tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*Def_Rad) * GV%m_to_H - if (OBC%number_of_segments .ne. 1) then + if (OBC%number_of_segments /= 1) then print *, 'Error in DOME OBC segment setup' return !!! Need a better error message here endif segment => OBC%segment(1) if (.not. segment%on_pe) return + NTR = tr_Reg%NTR + allocate(segment%field(NTR)) + do k=1,nz rst = -1.0 if (k>1) rst = -1.0 + (real(k-1)-0.5)/real(nz-1) @@ -318,9 +321,9 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) ! these variables are used. The following code is just a naive example. if (associated(tv%S)) then ! In this example, all S inflows have values of 35 psu. -! call add_tracer_OBC_values("S", tr_Reg, OBC_inflow=35.0) -! call register_segment_tracer(CS%tr_desc(m), param_file, GV, & -! segment, OBC_scalar=35.0) + name = 'salt' + call tracer_name_lookup(tr_Reg, tr_ptr, name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_scalar=35.0) endif if (associated(tv%T)) then ! In this example, the T values are set to be consistent with the layer @@ -337,17 +340,39 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) do k=1,nz ; T0(k) = T0(k) + (GV%Rlay(k)-rho_guess(k)) / drho_dT(k) ; enddo enddo - ! This is no longer a full 3-D array thanks to the segment code above, - ! which is what we want now. - allocate(OBC_T_v(isd:ied,JsdB:JedB,nz)) + ! Temperature on tracer 1??? + allocate(segment%field(1)%buffer_src(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB,nz)) do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied - OBC_T_v(i,J,k) = T0(k) + segment%field(1)%buffer_src(i,j,k) = T0(k) enddo ; enddo ; enddo -! call add_tracer_OBC_values("T", tr_Reg, OBC_in_v=OBC_T_v) -! call register_segment_tracer(CS%tr_desc(m), param_file, GV, & -! segment, OBC_array=.true.) + name = 'temp' + call tracer_name_lookup(tr_Reg, tr_ptr, name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_array=.true.) endif + ! Dye tracers - fight with T,S??? + ! First dye - only one with OBC values + ! This field(1) requires tr_D1 to be the first tracer. + allocate(segment%field(1)%buffer_src(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB,nz)) + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed ; do i=segment%HI%isd,segment%HI%ied + if (k < nz/2) then ; segment%field(1)%buffer_src(i,j,k) = 0.0 + else ; segment%field(1)%buffer_src(i,j,k) = 1.0 ; endif + enddo ; enddo ; enddo + name = 'tr_D1' + call tracer_name_lookup(tr_Reg, tr_ptr, name) + call register_segment_tracer(tr_ptr, param_file, GV, & + OBC%segment(1), OBC_array=.true.) + + ! 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,NTR + if (m < 10) then ; write(name,'("tr_D",I1.1)') m + else ; write(name,'("tr_D",I2.2)') m ; endif + call tracer_name_lookup(tr_Reg, tr_ptr, name) + call register_segment_tracer(tr_ptr, param_file, GV, & + OBC%segment(1), OBC_scalar=0.0) + enddo + end subroutine DOME_set_OBC_data !> \namespace dome_initialization diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 639c4839ce..34ef50b8cb 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -9,9 +9,9 @@ module ISOMIP_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_io, only : close_file, fieldtype, file_exists -use MOM_io, only : open_file, MOM_read_data, read_axis_data, SINGLE_FILE -use MOM_io, only : write_field, slasher, vardesc +use MOM_io, only : file_exists +use MOM_io, only : MOM_read_data +use MOM_io, only : slasher use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_type @@ -218,7 +218,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par enddo enddo ; enddo - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie eta1D(nz+1) = -1.0*G%bathyT(i,j) @@ -238,7 +238,7 @@ subroutine ISOMIP_initialize_thickness ( h, G, GV, param_file, tv, just_read_par do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) h(i,j,:) = GV%m_to_H * delta_h - end do ; end do + enddo ; enddo case default call MOM_error(FATAL,"isomip_initialize: "// & @@ -552,7 +552,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) enddo enddo ; enddo - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR ) ! Initial thicknesses for z coordinates do j=js,je ; do i=is,ie eta1D(nz+1) = -1.0*G%bathyT(i,j) do k=nz,1,-1 @@ -570,7 +570,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, tv, PF, use_ALE, CSp, ACSp) do j=js,je ; do i=is,ie delta_h = G%bathyT(i,j) / dfloat(nz) h(i,j,:) = delta_h - end do ; end do + enddo ; enddo case default call MOM_error(FATAL,"ISOMIP_initialize_sponges: "// & diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index f6df0505dc..63d61bea35 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -206,11 +206,12 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, h, Time) if (segment%direction == OBC_DIRECTION_N) cycle ! This should be somewhere else... - segment%Tnudge_in = 1.0/(0.3*86400) + segment%Velocity_nudging_timescale_in = 1.0/(0.3*86400) if (segment%direction == OBC_DIRECTION_W) then IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB jsd = segment%HI%jsd ; jed = segment%HI%jed + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB do j=jsd,jed ; do I=IsdB,IedB x1 = 1000. * G%geoLonCu(I,j) y1 = 1000. * G%geoLatCu(I,j) @@ -225,13 +226,27 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, h, Time) else segment%eta(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 - do k=1,nz - segment%nudged_normal_vel(I,j,k) = fac * CS%lambda / CS%F_0 * & + if (segment%nudged) then + do k=1,nz + segment%nudged_normal_vel(I,j,k) = fac * CS%lambda / CS%F_0 * & + exp(- CS%lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & + cos(CS%omega * time_sec) + enddo + elseif (segment%specified) then + do k=1,nz + segment%normal_vel(I,j,k) = fac * CS%lambda / CS%F_0 * & exp(- CS%lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * & cos(CS%omega * time_sec) - enddo + segment%normal_trans(I,j,k) = segment%normal_vel(I,j,k) * & + h(i+1,j,k) * G%dyCu(I,j) + enddo + endif endif enddo ; enddo +! if (allocated(segment%tangential_vel)) then +! do J=JsdB,JedB ; do I=IsdB,IedB +! enddo ; enddo +! endif else isd = segment%HI%isd ; ied = segment%HI%ied JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB @@ -249,10 +264,19 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, h, Time) else segment%eta(i,J) = 0.0 segment%normal_vel_bt(i,J) = 0.0 - do k=1,nz - segment%nudged_normal_vel(i,J,k) = fac * CS%lambda / CS%F_0 * & + if (segment%nudged) then + do k=1,nz + segment%nudged_normal_vel(i,J,k) = fac * CS%lambda / CS%F_0 * & + exp(- CS%lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa + enddo + elseif (segment%specified) then + do k=1,nz + segment%normal_vel(i,J,k) = fac * CS%lambda / CS%F_0 * & exp(- CS%lambda * y) * cos(PI * CS%mode * (k - 0.5) / nz) * cosa - enddo + segment%normal_trans(i,J,k) = segment%normal_vel(i,J,k) * & + h(i,j+1,k) * G%dxCv(i,J) + enddo + endif endif enddo ; enddo endif diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 new file mode 100644 index 0000000000..c464a2b1f6 --- /dev/null +++ b/src/user/MOM_wave_interface.F90 @@ -0,0 +1,1302 @@ +module MOM_wave_interface + +! This file is part of MOM6. See LICENSE.md for the license. + +!********+*********+*********+*********+*********+*********+*********+** +!* * +!* By Brandon Reichl, 2018. * +!* * +!* This module should be moved as wave coupling progresses and * +!* likely will should mirror the iceberg or sea-ice model set-up. * +!* * +!* This module is meant to contain the routines to read in and * +!* interpret surface wave data for MOM6. In its original form, the * +!* capabilities include setting the Stokes drift in the model (from a * +!* variety of sources including prescribed, empirical, and input * +!* files). In short order, the plan is to also ammend the subroutine * +!* to accept Stokes drift information from an external coupler. * +!* Eventually, it will be necessary to break this file apart so that * +!* general wave information may be stored in the control structure * +!* and the Stokes drift effect can be isolated from processes such as * +!* sea-state dependent momentum fluxes, gas fluxes, and other wave * +!* related air-sea interaction and boundary layer phenomenon. * +!* * +!* The Stokes drift are stored on the C-grid with the conventional * +!* protocol to interpolate to the h-grid to compute Langmuir number, * +!* the primary quantity needed for Langmuir turbulence * +!* parameterizations in both the ePBL and KPP approach. This module * +!* also computes full 3d Stokes drift profiles, which will be useful * +!* if second-order type boundary layer parameterizations are * +!* implemented (perhaps via GOTM, work in progress). * +!* * +!********+*********+*********+*********+*********+*********+*********+** + +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc +use MOM_diag_mediator, only : diag_ctrl +use MOM_domains, only : pass_var, pass_vector, AGRID +use MOM_domains, only : To_South, To_West, To_All +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_verticalgrid, only : verticalGrid_type +use MOM_safe_alloc, only : safe_alloc_ptr +use MOM_time_manager, only : time_type, operator(+), operator(/), get_time,& + time_type_to_real,real_to_time_type +use MOM_variables, only : thermo_var_ptrs, surface +use data_override_mod, only : data_override_init, data_override +implicit none ; private + +#include + +public MOM_wave_interface_init ! Public interface to fully initialize the wave routines. +public MOM_wave_interface_init_lite ! Public interface to quick initialize this module. +public Update_Surface_Waves ! Public interface to update wave information at the + ! coupler/driver level. +public Update_Stokes_Drift ! Public interface to update the Stokes drift profiles + ! called in step_mom. +public get_Langmuir_Number ! Public interface to compute Langmuir number called from + ! ePBL or KPP routines. +public StokesMixing ! NOT READY - Public interface to add down-Stokes gradient + ! momentum mixing (e.g. the approach of Harcourt 2013/2015) +public CoriolisStokes ! NOT READY - Public interface to add Coriolis-Stokes acceleration + ! of the mean currents, needed for comparison with LES. It is + ! presently advised against implementing in non-1d settings without + ! serious consideration of the full 3d wave-averaged Navier-Stokes + ! CL2 effects. +public Waves_end ! public interface to deallocate and free wave related memory. + + +!> Container for all surface wave related parameters +type, public:: wave_parameters_CS ; private + + !> Main surface wave options + logical, public :: UseWaves ! Flag to enable surface gravity wave feature + logical, public :: LagrangianMixing ! NOT READY + ! True if Stokes drift is present and mixing + ! should be applied to Lagrangian current + ! (mean current + Stokes drift). + ! See Reichl et al., 2016 KPP-LT approach + logical, public :: StokesMixing ! NOT READY + ! True if vertical mixing of momentum + ! should be applied directly to Stokes current + ! (with separate mixing parameter for Eulerian + ! mixing contribution). + ! See Harcourt 2013, 2015 Second-Moment approach + logical, public :: CoriolisStokes ! NOT READY + ! True if Coriolis-Stokes acceleration should be applied. + integer, public :: StkLevelMode=1 ! = 0 if mid-point value of Stokes drift is used + ! = 1 if average value of Stokes drift over level. + ! If advecting with Stokes transport, 1 is the correct + ! approach. + + !> Surface Wave Dependent 1d/2d/3d vars + real, allocatable, dimension(:), public :: & + WaveNum_Cen,& ! Wavenumber bands for read/coupled + Freq_Cen, & ! Frequency bands for read/coupled + PrescribedSurfStkX,& ! Surface Stokes drift if prescribed + PrescribedSurfStkY ! Surface Stokes drift if prescribed + real, allocatable, dimension(:,:,:), public :: & + Us_x ! 3d Stokes drift profile (zonal) + ! Horizontal -> U points + ! Vertical -> Mid-points + real, allocatable, dimension(:,:,:), public :: & + Us_y ! 3d Stokes drift profile (meridional) + ! Horizontal -> V points + ! Vertical -> Mid-points + real, allocatable, dimension(:,:), public :: & + LangNum, & ! Langmuir number (directionality factored later) + ! Horizontal -> H points + US0_x, & ! Surface Stokes Drift (zonal) + ! Horizontal -> U points + US0_y ! Surface Stokes Drift (meridional) + ! Horizontal -> V points + real, allocatable, dimension(:,:,:), public :: & + STKx0 ! Stokes Drift spectrum (zonal) + ! Horizontal -> U points + ! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:,:), public :: & + STKy0 ! Stokes Drift spectrum (meridional) + ! Horizontal -> V points + ! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:,:), public :: & + KvS !< Viscosity for Stokes Drift shear + + ! Pointers to auxiliary fields + type(time_type), pointer, public :: Time ! A pointer to the ocean model's clock. + type(diag_ctrl), pointer, public :: diag ! A structure that is used to regulate the + ! timing of diagnostic output. + + ! Diagnostic handles + integer, public :: id_surfacestokes_x, id_surfacestokes_y + integer, public :: id_3dstokes_x, id_3dstokes_y + +end type wave_parameters_CS + +!Options not needed outside of this module + +!> Main Option +integer :: WaveMethod=-99 + ! Options for including wave information + ! Valid (tested) choices are: + ! 0 - Test Profile + ! 1 - Surface Stokes Drift Bands + ! 2 - DHH85 + ! 3 - LF17 + ! -99 - No waves computed, but empirical Langmuir number used. + +!> Options if WaveMethod is Surface Stokes Drift Bands (1) +integer, public :: NumBands =0 !< Number of wavenumber/frequency partitions to receive + !! This needs to match the number of bands provided + !! via either coupling or file. +integer, public :: PartitionMode !< Method for partition mode (meant to check input) + !! 0 - wavenumbers + !! 1 - frequencies +integer :: DataSource ! Integer that specifies where the Model Looks for Data + ! Valid choices are: + ! 1 - FMS DataOverride Routine + ! 2 - Reserved For Coupler + ! 3 - User input (fixed values, useful for 1d testing) +!>> Options if using FMS DataOverride Routine +character(len=40) :: SurfBandFileName ! Filename if using DataOverride +logical :: dataoverrideisinitialized ! Flag for DataOverride Initialization + +!> Options for computing Langmuir number +real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number +logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number + +! This include declares and sets the variable "version". +#include "version_variable.h" + +character(len=40) :: mdl = "MOM_wave_interface" ! This module's name. + +! Switches needed in import_stokes_drift +integer, parameter :: TESTPROF = 0, SURFBANDS = 1, & + DHH85 = 2, LF17 = 3, NULL_WaveMethod=-99, & + DATAOVR = 1, COUPLER = 2, INPUT = 3 + +! For Test Prof +Real :: TP_STKX0, TP_STKY0, TP_WVL +logical :: WaveAgePeakFreq !> Flag to use W +real :: WaveAge, WaveWind +real :: PI + +CONTAINS + +!> Initializes parameters related to MOM_wave_interface +subroutine MOM_wave_interface_init(time,G,GV,param_file, CS, diag ) + + !Arguments + type(time_type), target, intent(in) :: Time !< Time + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(param_file_type), intent(in) :: param_file !< Input parameter structure + type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic Pointer + + ! Local variables + + ! I/O + character*(13) :: TMPSTRING1,TMPSTRING2 + character*(5), parameter :: NULL_STRING = "EMPTY" + character*(12), parameter :: TESTPROF_STRING = "TEST_PROFILE" + character*(13), parameter :: SURFBANDS_STRING = "SURFACE_BANDS" + character*(5), parameter :: DHH85_STRING = "DHH85" + character*(4), parameter :: LF17_STRING = "LF17" + character*(12), parameter :: DATAOVR_STRING = "DATAOVERRIDE" + character*(7), parameter :: COUPLER_STRING = "COUPLER" + character*(5), parameter :: INPUT_STRING = "INPUT" + + !/ Dummy Check + if (associated(CS)) then + call MOM_error(FATAL, "wave_interface_init called with an associated"//& + "control structure.") + return + endif + + PI=4.0*atan(1.0) + + !/ Allocate CS and set pointers + allocate(CS) + + CS%diag => diag + CS%Time => Time + + ! Add any initializations needed here + dataOverrideIsInitialized = .false. + + ! The only way to get here is with UseWaves enabled. + CS%UseWaves=.true. + + call log_version(param_file, mdl, version) + + ! 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.) + 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.) + if (CS%StokesMixing) then + !Force Code Intervention + 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.) + if (CS%CoriolisStokes) then + !Force Code Intervention + call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") + endif + + ! 1. Get Wave Method and write to integer WaveMethod + call get_param(param_file,mdl,"WAVE_METHOD",TMPSTRING1, & + "Choice of wave method, valid options include: \n"// & + " TEST_PROFILE - Prescribed from surface Stokes drift \n"// & + " and a decay wavelength.\n"// & + " SURFACE_BANDS - Computed from multiple surface values \n"// & + " and decay wavelengths.\n"// & + " DHH85 - Uses Donelan et al. 1985 empirical \n"// & + " wave spectrum with prescribed values. \n"// & + " LF17 - Infers Stokes drift profile from wind \n"// & + " speed following Li and Fox-Kemper 2017.\n", & + units='', default=NULL_STRING) + select case (TRIM(TMPSTRING1)) + case (NULL_STRING)! No Waves + call MOM_error(FATAL, "wave_interface_init called with no specified"//& + "WAVE_METHOD.") + case (TESTPROF_STRING)! Test Profile + WaveMethod = TESTPROF + call get_param(param_file,mdl,"TP_STKX_SURF",TP_STKX0,& + 'Surface Stokes (x) for test profile',& + units='m/s',default=0.1) + call get_param(param_file,mdl,"TP_STKY_SURF",TP_STKY0,& + 'Surface Stokes (y) for test profile',& + units='m/s',default=0.0) + call get_param(param_file,mdl,"TP_WVL",TP_WVL,& + units='m',default=50.0) + case (SURFBANDS_STRING)!Surface Stokes Drift Bands + 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) + select case (TRIM(TMPSTRING2)) + case (NULL_STRING)! + call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& + " but no SURFBAND_SOURCE.") + case (DATAOVR_STRING)!Using Data Override + DataSource = DATAOVR + call get_param(param_file, mdl, "SURFBAND_FILENAME", SurfBandFileName, & + "Filename of surface Stokes drift input band data.", default="StkSpec.nc") + case (COUPLER_STRING)!Reserved for coupling + DataSource = Coupler + case (INPUT_STRING) + DataSource = Input + call get_param(param_file,mdl,"SURFBAND_NB",NumBands, & + "Prescribe number of wavenumber bands for Stokes drift. \n"// & + " Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and \n"// & + " STOKES_Y, there are no safety checks in the code.", & + units='', default=1) + allocate( CS%WaveNum_Cen(1:NumBands) ) ; CS%WaveNum_Cen(:)=0.0 + allocate( CS%PrescribedSurfStkX(1:NumBands)) ; CS%PrescribedSurfStkX(:) = 0.0 + allocate( CS%PrescribedSurfStkY(1:NumBands)) ; CS%PrescribedSurfStkY(:) = 0.0 + allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:NumBands)) ; CS%STKx0(:,:,:) = 0.0 + allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:NumBands)) ; CS%STKy0(:,:,:) = 0.0 + partitionmode=0 + call get_param(param_file,mdl,"SURFBAND_WAVENUMBERS",CS%WaveNum_Cen, & + "Central wavenumbers for surface Stokes drift bands.",units='rad/m', & + default=0.12566) + call get_param(param_file,mdl,"SURFBAND_STOKES_X",CS%PrescribedSurfStkX, & + "X-direction surface Stokes drift for bands.",units='m/s', & + default=0.15) + call get_param(param_file,mdl,"SURFBAND_STOKES_Y",CS%PrescribedSurfStkY, & + "Y-direction surface Stokes drift for bands.",units='m/s', & + default=0.0) + case default + call MOM_error(FATAL,'Check WAVE_METHOD.') + end select + + case (DHH85_STRING)!Donelan et al., 1985 spectrum + WaveMethod = DHH85 + call get_param(param_file,mdl,"DHH85_AGE_FP",WaveAgePeakFreq, & + "Choose true to use waveage in peak frequency.", & + units='', default=.false.) + call get_param(param_file,mdl,"DHH85_AGE",WaveAge, & + "Wave Age for DHH85 spectrum.", & + units='', default=1.2) + call get_param(param_file,mdl,"DHH85_WIND",WaveWind, & + "Wind speed for DHH85 spectrum.", & + units='', default=10.0) + case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number + WaveMethod = LF17 + case default + call MOM_error(FATAL,'Check WAVE_METHOD.') + end select + + ! Langmuir number Options + call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & + "The depth (normalized by BLD) to average Stokes drift over in \n"//& + " Lanmguir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim",default=0.04) + call get_param(param_file, mdl, "LA_MISALIGNMENT", LA_Misalignment, & + "Flag (logical) if using misalignment bt shear and waves in LA",& + default=.false.) + + ! 2. Allocate and initialize + ! Stokes drift + ! Profiles + allocate(CS%Us_x(G%isdB:G%IedB,G%jsd:G%jed,G%ke)) ; CS%Us_x(:,:,:) = 0.0 + allocate(CS%Us_y(G%isd:G%Ied,G%jsdB:G%jedB,G%ke)) ; CS%Us_y(:,:,:) = 0.0 + ! Surface Values + allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed)) ; CS%US0_x(:,:) = 0.0 + allocate(CS%US0_y(G%isd:G%ied,G%jsdB:G%jedB)) ; CS%US0_y(:,:) = 0.0 + ! Langmuir number + allocate(CS%LangNum(G%isc:G%iec,G%jsc:G%jec)) ; CS%LangNum(:,:) = 0.0 + + if (CS%StokesMixing) then + ! Viscosity for Stokes drift + allocate(CS%KvS(G%isd:G%Ied,G%jsd:G%jed,G%ke)) ; CS%KvS(:,:,:) = 0.0 + endif + + ! + ! 3. Initialize Wave related outputs + ! + CS%id_surfacestokes_y = register_diag_field('ocean_model','surface_stokes_y', & + CS%diag%axesCu1,Time,'Surface Stokes drift (y)','m s-1') + CS%id_surfacestokes_x = register_diag_field('ocean_model','surface_stokes_x', & + CS%diag%axesCv1,Time,'Surface Stokes drift (x)','m s-1') + CS%id_3dstokes_y = register_diag_field('ocean_model','3d_stokes_y', & + CS%diag%axesCvL,Time,'3d Stokes drift (y)','m s-1') + CS%id_3dstokes_x = register_diag_field('ocean_model','3d_stokes_x', & + CS%diag%axesCuL,Time,'3d Stokes drift (y)','m s-1') + + return + +end subroutine MOM_wave_interface_init + + +subroutine MOM_wave_interface_init_lite(param_file) + !It is possible to estimate Stokes drift without the Wave data (if WaveMethod=LF17). + ! In this case there are still a couple inputs we need to read in, which is done + ! here in a reduced wave_interface_init that doesn't allocate the CS. + + !Arguments + type(param_file_type), intent(in) :: param_file !< Input parameter structure + + + ! Langmuir number Options + call get_param(param_file, mdl, "LA_DEPTH_RATIO", LA_FracHBL, & + "The depth (normalized by BLD) to average Stokes drift over in \n"//& + " Lanmguir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim",default=0.04) + + if (WaveMethod==NULL_WaveMethod) then + ! Wave not initialized. Check for WaveMethod. Only allow LF17. + WaveMethod=LF17 + PI=4.0*atan(1.0) + endif + + return +end subroutine MOM_wave_interface_init_lite + +! Place to add update of surface wave parameters. +subroutine Update_Surface_Waves(G,GV,Day,DT,CS) +!Arguments + type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure + type(ocean_grid_type), intent(inout) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(time_type), intent(in) :: Day !